Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Applications/NIH Image 1.62b11/src/File1.p

Text File | 1997-05-06 | 100KB | 3,559 lines

unit File1;

{Routines used by NIH Image for implementing File Menu commands.}

interface


    uses
        Types, Memory, QuickDraw, QuickDrawText, Packages, Menus, Events, Fonts,
        Scrap, ToolUtils, Resources, Errors, Palettes, StandardFile, Windows,
        Controls, TextEdit, Files, Dialogs, TextUtils, Finder, MixedMode, SegLoad,
        globals, Utilities, Graphics, file2, Dicom, sound, Lut, Text, Processes;

    function CloseAWindow (WhichWindow: WindowPtr): integer;
    procedure DoClose;
    function OpenFile (fname: str255; vnum: integer): boolean;
    function OpenPict (fname: str255; vnum: integer; Reverting: boolean): boolean;
    procedure SaveFile;
    function DoOpen (FileName: str255; RefNum: integer): boolean;
    function ImportFile (FileName: str255; RefNum: integer): boolean;
    procedure RevertToSaved;
    procedure SaveAs (name: str255; RefNum: integer);
    procedure Export (name: str255; RefNum: integer);
    procedure FindWhatToPrint;
    procedure UpdateFileMenu;
    procedure SaveAsText (fname: str255; RefNum: integer);
    procedure SaveAll;
    function OpenPICS (name: str255; fRefNum: integer): boolean;
    procedure RescaleToEightBits;


implementation

    var
        OpenAllFiles, UseExistingLUT, PICTReadErr: boolean;
        SaveRefNum: integer;
        TempStackInfo: StackInfoRec;
        PictSrcRect: rect;

{$PUSH}
{$D-}

    procedure LookForCluts (fname: str255; vnum: integer);
        var
            RefNum: integer;
            err: OSErr;
            ok1, ok2: boolean;
    begin
        if not UseExistingLUT then begin
                err := SetVol(nil, vnum);
                refNum := OpenResFile(fname);
                if RefNum <> -1 then begin
                        ok1 := LoadCLUTResource(KlutzID);
                        if not ok1 then
                            ok2 := LoadCLUTResource(PixelPaintID);
                        CloseResFile(refNum);
                    end;
            end;
    end;



    function OpenImageHeader (f: integer; fname: str255; vnum: integer): boolean;
        var
            ByteCount: LongInt;
            err: OSErr;
            TempHdr: PicHeader;
            i, OldNExtra, p1x, p2x: integer;
            ok: boolean;
            hUnitsKind: UnitsType;
    begin
        if SizeOf(PicHeader)<>HeaderSize then begin
            PutError(StringOf('Internal error (size= ', SizeOf(PicHeader):1,')'));
            OpenImageHeader := false;
            exit(OpenImageHeader);
        end;
        ByteCount := HeaderSize;
        err := SetFPos(f, fsFromStart, info^.HeaderOffset);
        err := fsread(f, ByteCount, @TempHdr);
        if CheckIO(err) <> NoErr then begin
                OpenImageHeader := false;
                exit(OpenImageHeader);
            end;
        with info^, TempHdr do begin
                if PictureType <> TiffFile then begin
                        nlines := hnlines;
                        PixelsPerLine := hPixelsPerLine;
                    end;
                if (hversion > 54) and not UseExistingLUT then begin
                        OldNExtra := nExtraColors;
                        nExtraColors := hnExtraColors;
                        ExtraColors := hExtraColors;
                        if (nExtraColors > 0) or (OldNExtra <> nExtraColors) then
                            RedrawLUTWindow;
                    end;
                if (hversion >= 42) and not UseExistingLUT then begin
                        if hversion < 142 then begin
                                LUTMode := hOldLUTMode;
                                if (LutMode = OldAppleDefault) or (LutMode = OldSpectrum) then
                                    LutMode := ColorLut;
                            end
                        else begin
                                LUTMode := hLUTMode;
                                if LutMode = Pseudocolor then begin
                                        if ((hnColors > 32) and (hTable = CustomTable)) or (hTable > spectrum) then
                                            LutMode := ColorLut;
                                    end;
                            end;
                        case LUTMode of
                            PseudoColor:
                                if hversion < 142 then begin
                                        nColors := hOldnColors;
                                        for i := 0 to ncolors - 1 do begin
                                                RedLUT[i] := hr[i];
                                                GreenLUT[i] := hg[i];
                                                BlueLUT[i] := hb[i];
                                            end;
                                        ColorEnd := 255 - hOldColorStart;
                                        ColorStart := ColorEnd - nColors * hColorWidth + 1;
                                        if ColorStart < 0 then
                                            ColorStart := 0;
                                        InvertPalette;
                                        FillColor1 := BlackRGB;
                                        FillColor2 := BlackRGB;
                                        ColorTable := CustomTable;
                                        UpdateLUT;
                                    end
                                else begin {V1.42 or later}
                                        if (hTable <> CustomTable) and (hTable <= spectrum) then begin
                                                SwitchColorTables(GetColorTableItem(hTable), false);
                                                if hInvertedTable then
                                                    InvertPalette;
                                            end
                                        else begin
                                                nColors := hnColors;
                                                ColorTable := CustomTable;
                                                if nColors <= 32 then
                                                    for i := 0 to ncolors - 1 do begin
                                                            RedLUT[i] := hr[i];
                                                            GreenLUT[i] := hg[i];
                                                            BlueLUT[i] := hb[i];
                                                        end;
                                            end;
                                        ColorStart := hColorStart;
                                        ColorEnd := hColorEnd;
                                        FillColor1 := hFill1;
                                        FillColor2 := hFill2;
                                        UpdateLUT;
                                        UpdateMap;
                                    end; {v1.42 or later}
                            GrayScale:
                                ResetGrayMap;
                            ColorLut, CustomGrayscale:
                                if PictureType <> PictFile then begin
                                        if ColorMapOffset > 0 then
                                            GetTiffColorMap(f)
                                        else
                                            LookForCluts(fname, vnum);
                                    end;
                            otherwise
                        end; {case}
                        if hLutMode = CustomGrayscale then
                            LutMode := CustomGrayscale;
                    end;{if}
                if (hversion >= 65) and ((ForegroundIndex <> hForegroundIndex) or (BackgroundIndex <> hBackgroundIndex)) then begin
                        SetForegroundColor(hForegroundIndex);
                        SetBackgroundColor(hBackgroundIndex);
                    end;
                if (hversion > 88) and (LUTMode = GrayScale) and not UseExistingLUT then begin
                        if hversion < 138 then begin
                                p1x := 255 - hp2x;
                                p2x := 255 - hp1x;
                            end
                        else begin
                                p1x := hp1x;
                                p2x := hp2x
                            end;
                        nColors := 256;
                        ColorStart := p1x;
                        ColorEnd := p2x;
                        UpdateLUT;
                    end;
                if hversion > 106 then begin
                        {xScale := hXScale;} {68k-bug}
                        xScale := DoubleToReal(hXScale);
                        yScale := xScale;
                        PixelAspectRatio := 1.0;
                        SpatiallyCalibrated := xScale <> 0.0;
                    end;
                if hversion > 140 then begin
                        PixelAspectRatio := hPixelAspectRatio;
                        yScale := xScale / PixelAspectRatio;
                    end;
                if hversion > 153 then
                    xUnit := hXUnit
                else begin
                        hUnitsKind := UnitsType(hUnitsID - 5);
                        GetXUnits(hUnitsKind);
                    end;
                if xUnit = 'pixel' then
                    SpatiallyCalibrated := false;
                if ((hnCoefficients > 0) and (hfit < Uncalibrated)) or (hfit = UncalibratedOD) then begin
                        if hfit = SpareFit1 then begin
                                fit := uncalibrated;
                                DrawLabels('', '', '');
                            end
                        else begin
                                fit := hfit;
                                if hfit <> UncalibratedOD then begin
                                        nCoefficients := hnCoefficients;
                                        for i:=1 to maxCoeff do
                                            {Coefficient[i] := hCoeff[i];} {68k-bug}
                                            Coefficient[i]:=DoubleToReal(hCoeff[i]);
                                        nKnownValues := 0;
                                    end;
                                UnitOfMeasure := hUM;
                                if hversion >= 144 then
                                    ZeroClip := hZeroClip
                                else
                                    ZeroClip := false;
                            end;
                    end
                else begin
                        fit := uncalibrated;
                        DrawLabels('', '', '');
                    end;
                BinaryPic := hBinaryPic;
                if hSliceEnd > 1 then begin
                        SliceStart := hSliceStart;
                        SliceEnd := hSliceEnd;
                        if SliceEnd > 254 then
                            SliceEnd := 254;
                    end;
                if hNSlices > 1 then begin
                        with TempStackInfo do begin
                            nSlices := hNSlices;
                            if nSlices > MaxSlices then
                                nSlices := MaxSlices;
                            CurrentSlice := hCurrentSlice;
                            if (hCurrentSlice < 1) or (hCurrentSlice > nSlices) then
                                CurrentSlice := 1;
                            SliceSpacing := hSliceSpacing;
                            FrameInterval := hFrameInterval;
                            StackType := VolumeStack;
                            if hVersion >= 158 then
                                StackType := hStackType;
                        end;
                    end;
                FileVersion := hVersion;
                OpenImageHeader := true
            end;
    end;


    function OpenHeader (f: integer; fname: str255; vnum: integer; var TiffInfo: TiffInfoRec): boolean;
        var
            ByteCount, FileSize, DirOffset, MaxImages: LongInt;
            hdr: packed array[1..512] of byte;
            err: OSErr;
            TempHdr: PicHeader;
    begin
        with info^ do begin
                if (WhatToOpen = OpenUnknown) or (WhatToOpen = OpenImported) then begin
                        err := SetFPos(f, fsFromStart, 0);
                        ByteCount := 8;
                        err := fsread(f, ByteCount, @hdr);
                        if ((hdr[1] = 73) and (hdr[2] = 73)) or ((hdr[1] = 77) and (hdr[2] = 77)) then
                            WhatToOpen := OpenTIFF
                        else if WhatToOpen = OpenUnknown then
                            WhatToOpen := OpenImage
                        else
                            WhatToOpen := OpenMCID;
                    end;
                StackInfo := nil;
                with TempStackInfo do begin
                        nSlices := 0;
                        CurrentSlice := 1;
                        SliceSpacing := 0.0;
                        FrameInterval := 0.0;
                    end;
                fileVersion := 0;
                case WhatToOpen of
                    OpenImage:  begin
                            err := SetFPos(f, fsFromStart, 0);
                            ByteCount := 8;
                            err := fsread(f, ByteCount, @TempHdr);
                            if TempHdr.FileID = FileID8 then begin
                                    HeaderOffset := 0;
                                    PictureType := normal
                                end
                            else begin
                                    HeaderOffset := -1;
                                    BlockMove(@TempHdr, @hdr, 8);
                                    nlines := hdr[1] + hdr[2] * 256;
                                    PixelsPerLine := hdr[3] + hdr[4] * 256;
                                    PictureType := Imported;
                                    InvertedImage := true;
                                end;
                            ImageDataOffset := 512;
                        end;
                    OpenMCID:  begin
                            err := SetFPos(f, fsFromStart, 0);
                            ByteCount := 4;
                            err := fsread(f, ByteCount, @hdr);
                            PixelsPerLine := hdr[1] + hdr[2] * 256 + 1;
                            if PixelsPerLine > MaxLine then begin
                                    beep;
                                    PixelsPerLine := MaxLine;
                                end;
                            nlines := hdr[3] + hdr[4] * 256 + 1;
                            PictureType := imported;
                            LUTMode := grayscale;
                            HeaderOffset := -1;
                            ImageDataOffset := 4;
                        end;
                    OpenCustom:  begin
                            err := GetEof(f, FileSize);
                            if macro then begin
                                    if (ImportCustomOffset + ImportCustomWidth * ImportCustomHeight) > FileSize then begin
                                            AbortMacro;
                                            OpenHeader := false;
                                            exit(OpenHeader)
                                        end;
                                end;
                            PixelsPerLine := ImportCustomWidth;
                            nlines := ImportCustomHeight;
                            PictureType := imported;
                            HeaderOffset := -1;
                            ImageDataOffset := ImportCustomOffset;
                            if ImportCustomSlices > 1 then
                                with TempStackInfo do begin
                                        nSlices := ImportCustomSlices;
                                        MaxImages := (FileSize - ImportCustomOffset) div (ImportCustomWidth * ImportCustomHeight);
                                        if nSlices > MaxImages then
                                            nSlices := MaxImages;
                                        if nSlices < 2 then
                                            nSlices := 0;
                                    end;
                        end;
                    OpenPICT2:  begin
                            err := SetFPos(f, fsFromStart, 0);
                            ByteCount := 8;
                            err := fsread(f, ByteCount, @TempHdr);
                            if TempHdr.FileID = FileID8 then
                                HeaderOffset := 0
                            else
                                HeaderOffset := -1;
                            PictureType := PictFile;
                            if not UseExistingLUT then
                                LutMode := ColorLut;
                            ImageDataOffset := 512;
                        end;
                    OpenTIFF:  begin
                            if not OpenTiffHeader(f, DirOffset) then begin
                                    OpenHeader := false;
                                    exit(OpenHeader)
                                end;
                            if not OpenTiffDirectory(f, DirOffset, TiffInfo, false) then begin
                                    OpenHeader := false;
                                    exit(OpenHeader)
                                end;
                            with TiffInfo do begin
                                    PictureType := TiffFile;
                                    PixelsPerLine := width;
                                    nlines := height;
                                    if BitsPerPixel = 4 then
                                        PictureType := FourBitTiff;
                                    ImageDataOffset := OffsetToData;
                                    InvertedImage := ZeroIsBlack and (PictureType <> FourBitTIFF);
                                    if resolution > 0.0 then begin
                                            case ResUnits of
                                                tNoUnits:
                                                    xUnit := 'pixel';
                                                tCentimeters:
                                                    xUnit := 'cm';
                                                tInches:
                                                    xUnit := 'inch';
                                            end;
                                            xScale := resolution;
                                            yScale := resolution;
                                            PixelAspectRatio := 1.0;
                                            if xUnit <> 'pixel' then
                                                SpatiallyCalibrated := true;
                                        end;
                                    ColorMapOffset := OffsetToColorMap;
                                    HeaderOffset := OffsetToImageHeader;
                                end;
                            if not UseExistingLUT then
                                LutMode := Grayscale;
                        end;
                end; {case}
                if HeaderOffset <> -1 then begin
                        if not OpenImageHeader(f, fname, vnum) then begin
                                OpenHeader := false;
                                exit(OpenHeader)
                            end
                    end
                else if (ColorMapOffset > 0) and not UseExistingLUT then
                    GetTiffColorMap(f);
            end; {with}
        OpenHeader := true;
    end;



    function SaveHeader (f, slines, sPixelsPerLine, vnum: integer; fname: str255; SavingSelection, SavingTIFF: boolean): OSErr;
        var
            TempHdr: PicHeader;
            DummyHdr: array[1..128] of LongInt;
            i: integer;
            ByteCount: LongInt;
            position: LongInt;
            err: OSErr;
            str: str255;
            UnitsKind: UnitsType;
            UnitsPerCM: extended;
    begin
        with TempHdr, info^ do begin
                for i := 1 to 128 do
                    DummyHdr[i] := 0;
                BlockMove(@DummyHdr, @TempHdr, HeaderSize);
                FileID := FileID8;
                hnlines := nlines;
                hPixelsPerLine := PixelsPerLine;
                hversion := version;
                hLUTMode := LUTMode;
                hOldLutMode := LutMode;
                hnColors := ncolors;
                hOldnColors := 0;
                if LutMode = Pseudocolor then begin
                        hOldLutMode := ColorLut;
                        if (ColorTable = CustomTable) and (ncolors <= 32) then
                            for i := 0 to nColors - 1 do begin
                                    hr[i] := RedLUT[i];
                                    hg[i] := GreenLUT[i];
                                    hb[i] := BlueLUT[i];
                                end;
                    end;
                hColorStart := ColorStart;
                hColorEnd := ColorEnd;
                hFill1 := FillColor1;
                hFill2 := FillColor2;
                hTable := ColorTable;
                hInvertedTable := InvertedColorTable;
                hOldColorStart := 255 - ColorEnd;
                if nColors > 0 then
                    hColorWidth := (ColorEnd - ColorStart) div nColors
                else
                    hColorWidth := 1;
                hnExtraColors := nExtraColors;
                hExtraColors := ExtraColors;
                hForegroundIndex := ForegroundIndex;
                hBackgroundIndex := BackgroundIndex;
                {hXScale := xScale;} {68k-bug}
                RealToDouble(xScale, hXScale);
                hScaleMagnification := 1.0;
                hPixelAspectRatio := PixelAspectRatio;
                hUnitsID := 14; {Pixels. For backward compatibility only since hUnits no longer used.}
                if SpatiallyCalibrated then begin
                        GetUnitsKind(UnitsKind, UnitsPerCM);
                        hUnitsID := ord(UnitsKind) + 5;
                        if hUnitsID > 14 then
                            hUnitsID := 14;
                    end;
                FindPoints(hp1x, hp1y, hp2x, hp2y);
                if fit = uncalibrated then
                    hnCoefficients := 0
                else
                    hnCoefficients := nCoefficients;
                hfit := fit;
                for i:=1 to maxCoeff do
                    {hCoeff[i] := Coefficient[i];} {68k-bug}
                    RealToDouble(Coefficient[i], hCoeff[i]);
                hZeroClip := ZeroClip;
                hUM := UnitOfMeasure;
                hBinaryPic := BinaryPic;
                hSliceStart := SliceStart;
                hSliceEnd := SliceEnd;
                if StackInfo <> nil then
                    with StackInfo^ do begin
                            hNSlices := nSlices;
                            hSliceSpacing := SliceSpacing;
                            hFrameInterval := FrameInterval;
                            hCurrentSlice := CurrentSlice;
                            hStackType := StackType;
                        end
                else begin
                        hNSlices := 0;
                        hSliceSpacing := 0.0;
                        hFrameInterval := 0.0;
                        hCurrentSlice := 0;
                        hStackType := VolumeStack;
                    end;
                hXUnit := xUnit;
                ByteCount := SizeOf(TempHdr);
                if ByteCount <> HeaderSize then begin
                        NumToString(ByteCount, str);
                        PutError('Internal error check: header size is incorrect.');
                        ExitToShell;
                    end;
                if SavingSelection then begin
                        hnlines := slines;
                        hPixelsPerLine := sPixelsPerLine;
                    end;
                err := fswrite(f, ByteCount, @TempHdr);
                SaveHeader := CheckIO(err);
            end; {with}
    end;


    procedure PackLines;
  {For odd width images, removes the extra bytes at the end of each line required to make RowBytes even.}
        var
            i: integer;
            SrcPtr, DstPtr: ptr;
    begin
        with info^ do begin
                SrcPtr := ptr(ord4(PicBaseAddr) + BytesPerRow);
                DstPtr := ptr(ord4(PicBaseAddr) + PixelsPerLine);
                for i := 1 to nlines - 1 do begin
                        BlockMove(SrcPtr, DstPtr, PixelsPerLine);
                        SrcPtr := ptr(ord4(SrcPtr) + BytesPerRow);
                        DstPtr := ptr(ord4(DstPtr) + PixelsPerLine);
                    end;
            end;
    end;


    procedure UnpackLines;
  {For odd width images, adds an extra byte to each line so RowBytes is even.}
        var
            i: integer;
            SrcPtr, DstPtr: ptr;
    begin
        with info^ do begin
                SrcPtr := ptr(ord4(PicBaseAddr) + (nlines - 1) * PixelsPerLine);
                DstPtr := ptr(ord4(PicBaseAddr) + (nlines - 1) * BytesPerRow);
                for i := 1 to nlines - 1 do begin
                        BlockMove(SrcPtr, DstPtr, PixelsPerLine);
                        SrcPtr := ptr(ord4(SrcPtr) - PixelsPerLine);
                        DstPtr := ptr(ord4(DstPtr) - BytesPerRow);
                    end;
            end;
    end;


    function WriteSlices (f: integer): integer;
        var
            ByteCount, SelectionSize: LongInt;
            i, err, SaveCS: integer;
    begin
        with info^, Info^.StackInfo^ do begin
                SaveCS := CurrentSlice;
                for i := 1 to nSlices do begin
                        CurrentSlice := i;
                        SelectSlice(CurrentSlice);
                        UpdateTitleBar;
                        ByteCount := ImageSize;
                        if odd(PixelsPerLine) then
                            PackLines;
                        err := fswrite(f, ByteCount, PicBaseAddr);
                        if odd(PixelsPerLine) then
                            UnpackLines;
                        if err <> 0 then
                            leave;
                    end;
                CurrentSlice := SaveCS;
                SelectSlice(CurrentSlice);
                UpdateTitleBar;
                WriteSlices := err;
            end;
    end;


    procedure WriteSelection (f: integer; sLines, sPixelsPerLine: LongInt);
  {Contributed by Edward J. Huff([e-mail]).}
        var
            size, offset, ByteCount, BytesDone: LongInt;
            src, dst: ptr;
            err: OSErr;
    begin
        if sPixelsPerLine > UndoBufSize then
            exit(WriteSelection);
        size := sLines * sPixelsPerLine;
        with info^, info^.RoiRect do begin
                offset := top * BytesPerRow + left;
                src := ptr(ord4(PicBaseAddr) + offset);
                BytesDone := 0;
                while BytesDone < size do begin
                        ByteCount := 0;
                        dst := UndoBuf;
                        while ((ByteCount + sPixelsPerLine) < UndoBufSize) and (BytesDone < size) do begin
                                BlockMove(src, dst, sPixelsPerLine);
                                src := ptr(ord4(src) + BytesPerRow);
                                dst := ptr(ord4(dst) + sPixelsPerLine);
                                ByteCount := ByteCount + sPixelsPerLine;
                                BytesDone := BytesDone + sPixelsPerLine;
                            end;
                        err := fswrite(f, ByteCount, UndoBuf);
                    end;
                SetupUndo; {Needed for drawing roi outline}
            end
    end;


    procedure SaveRGBTiff(f: integer; SavingSelection: boolean);
    const
        bufsize = 12000;
    var
        i, row, pixel, count, ignore: LongInt;
        vstart, height, hstart, width: LongInt;
        buffer: packed array [0 .. bufsize] of byte;
        rLine, gLine, bLine: LineType;
        err: OSErr;
    begin
        with info^ do begin
            if SavingSelection then with RoiRect do begin
                vstart := top;
                height := bottom - top;
                hstart := left;
                width := right - left;
            end else begin
                vstart := 0;
                height := nLInes;
                hstart := 0;
                width := PixelsPerLine;
            end;
            if width > MaxLine then
                exit(SaveRGBTiff);
            ShowMeter;
            count := 0;
            for row:=0 to height - 1 do begin
                if (row mod 10) = 0 then
                    UpdateMeter(((row * 100) div height), 'Saving RGB TIFF');
                SelectSlice(1);
                GetLine(hstart, vstart + row, width, rLine);
                SelectSlice(2);
                GetLine(hstart, vstart + row, width, gLine);
                SelectSlice(3);
                GetLine(hstart, vstart + row, width, bLine);
                for pixel := 0 to width - 1 do begin
                    buffer[count] := 255 - rLine[pixel];
                    buffer[count + 1] := 255 - gLine[pixel];
                    buffer[count + 2] := 255 - bLine[pixel];
                    count := count + 3;
                    if count > (bufsize - 3) then begin
                        if CheckIO(fswrite(f, count, @buffer)) <> noErr then begin
                            exit(SaveRGBTiff);
                            UpdateMeter(-1, '');
                        end;
                        count := 0;
                    end;
                end; {for}
            end; {for}
            if count > 0 then
                err := fswrite(f, count, @buffer);
            UpdateMeter(-1, '');
            with StackInfo^ do begin
                CurrentSlice := 1;
                SelectSlice(CurrentSlice);
            end;
            UpdateTitleBar;
        end; {with}
    end;


    function SaveTiffFile (fname: str255; vnum: integer; slines, sPixelsPerLine: integer; SavingSelection: boolean): boolean;
        var
            f, err, i, width, height: integer;
            HdrSize, ByteCount, ctabSize, StackTiffDirSize, ImageDataSize: LongInt;
            TheInfo: FInfo;
            MCIDHeader: packed array[1..4] of byte;
            SaveColorMap, SaveAs24BitTiff: boolean;
    begin
        SaveTiffFile := false;
        SaveAs24BitTiff := false;
        ShowWatch;
        err := fsopen(fname, vNum, f);
        if CheckIO(err) <> 0 then
            exit(SaveTiffFile);
        with Info^ do begin
                SaveColorMap := (LutMode <> Grayscale) and (SaveAsWhat <> asRawData);
                if SaveAsWhat = SaveAsMCID then begin
                        if SavingSelection then begin
                                width := sPixelsPerLine;
                                height := slines;
                            end
                        else begin
                                width := PixelsPerLine;
                                height := nLines;
                            end;
                        MCIDHeader[1] := (width - 1) mod 256;
                        MCIDHeader[2] := (width - 1) div 256;
                        MCIDHeader[3] := (height - 1) mod 256;
                        MCIDHeader[4] := (height - 1) div 256;
                        ByteCount := 4;
                        err := fswrite(f, ByteCount, @MCIDHeader);
                    end;
                HeaderOffset := TiffDirSize;
                ImageDataOffset := TiffDirSize + HeaderSize;
                if SaveColorMap then
                    ctabSize := SizeOf(TiffColorMapType)
                else
                    ctabSize := 0;
                StackTiffDirSize := 0;
                if SavingSelection then
                    ImageDataSize := ord4(sLines) * sPixelsPerLine
                else
                    ImageDataSize := ImageSize;
                if StackInfo <> nil then begin
                        ImageDataSize := ImageSize * StackInfo^.nSlices;
                        if SaveAsWhat <> asRawData then
                            StackTiffDirSize := SizeOf(StackIFDType) * (StackInfo^.nSlices - 1);
                        if (StackInfo^.StackType = rgbStack) and (StackInfo^.nSlices = 3) then begin
                            SaveAs24BitTiff := true;
                            ctabSize := 0;
                            StackTiffDirSize := 0;
                        end;
                    end;
                if (SaveAsWhat <> asRawData) and (SaveAsWhat <> SaveAsMCID) then begin
                        if SaveTiffDir(f, slines, sPixelsPerLine, SavingSelection, ctabSize, ImageDataSize) <> NoErr then begin
                                err := fsclose(f);
                                err := FSDelete(fname, vnum);
                                exit(SaveTiffFile)
                            end;
                        err := SetFPos(f, FSFromStart, TiffDirSize);
                        if SaveHeader(f, slines, sPixelsPerLine, vnum, fname, SavingSelection, true) <> NoErr then begin
                                err := fsclose(f);
                                err := FSDelete(fname, vnum);
                                exit(SaveTiffFile)
                            end;
                    end;
                if SaveAsWhat = SaveAsMCID then
                    KillRoi;
                if SaveAs24bitTiff then
                    SaveRGBTiff(f, SavingSelection)
                else if SavingSelection then
                    WriteSelection(f, sLines, sPixelsPerLine)
                else if StackInfo <> nil then
                    err := WriteSlices(f)
                else begin
                        ByteCount := ImageDataSize;
                        if odd(PixelsPerLine) then
                            PackLines;
                        err := fswrite(f, ByteCount, PicBaseAddr);
                        if odd(PixelsPerLine) then
                            UnpackLines;
                    end;
                if SaveAsWhat = SaveAsMCID then
                    InvertPic;
                if CheckIO(err) <> 0 then begin
                        err := fsclose(f);
                        err := FSDelete(fname, vnum);
                        exit(SaveTiffFile)
                    end;
                if SaveAsWhat = asRawData then
                    HdrSize := 0
                else if SaveAsWhat = SaveAsMCID then begin
                        HdrSize := 4;
                        SaveAsWhat := asRawData;
                    end
                else
                    HdrSize := HeaderSize + TiffDirSize;
                if SaveColorMap then
                    SaveTiffColorMap(f, ImageDataSize);
                if StackTiffDirSize > 0 then
                    err := WriteExtraTiffIFDs(f, ImageDataSize, cTabSize);
                err := SetEOF(f, HdrSize + ImageDataSize + ctabSize + StackTiffDirSize);
                err := fsclose(f);
                err := GetFInfo(fname, vnum, TheInfo);
                if TheInfo.fdCreator <> 'Imag' then begin
                        TheInfo.fdCreator := 'Imag';
                        err := SetFInfo(fname, vnum, TheInfo);
                    end;
                if SaveAsWhat = asRawData then begin
                        TheInfo.fdType := 'RawD';
                        err := SetFInfo(fname, vnum, TheInfo);
                    end
                else if TheInfo.fdType <> 'TIFF' then begin
                        TheInfo.fdType := 'TIFF';
                        err := SetFInfo(fname, vnum, TheInfo);
                    end;
                err := FlushVol(nil, vNum);
                if not SavingSelection then begin
                        if (PictureType <> BlankField) and (PictureType <> FrameGrabberType)  and (SaveAsWhat <> asRawData) then begin
                                PictureType := TiffFile;
                                RemovePath(fname);
                                TruncateString(fname, maxTitle);
                                title := fname;
                                vref := vnum;
                                UpdateTitleBar;
                                if StackInfo = nil then begin
                                        revertable := true;
                                        InvertedImage := false;
                                    end;
                            end;
                    end;
                if (SaveAsWhat <> asRawData) and (not RoiShowing) then
                    Changes := false;
            end; {with}
        SaveTiffFile := true;
    end;


    procedure SaveAsTIFF (fname: str255; RefNum: integer; slines, sPixelsPerLine: integer; SavingSelection: boolean);
        var
            err: integer;
            TheInfo: FInfo;
            replacing, ok: boolean;
            name: str255;
    begin
        if info = NoInfo then
            exit(SaveAsTIFF);
        err := GetFInfo(fname, RefNum, TheInfo);
        case err of
            NoErr:
                with TheInfo do begin
                        if (fdType <> 'TIFF') and (fdType <> 'PICT') and (fdType <> 'IPIC') and (fdType <> 'RawD') and (fdType <> 'PICS') then begin
                                TypeMismatch(fname);
                                exit(SaveAsTIFF)
                            end;
                        replacing := true;
                    end;
            FNFerr:  begin
                    if SaveAsWhat = asRawData then
                        err := create(fname, RefNum, 'Imag', 'RawD')
                    else
                        err := create(fname, RefNum, 'Imag', 'TIFF');
                    if CheckIO(err) <> 0 then
                        exit(SaveAsTIFF);
                    replacing := false;
                end;
            otherwise
                if CheckIO(err) <> 0 then
                    exit(SaveAsTIFF);
        end;
        if replacing then
            if not RoomForFile(fname, RefNum, slines, sPixelsPerLine, SavingSelection) then
                exit(SaveAsTIFF);
        ok := SaveTiffFile(fname, RefNum, slines, sPixelsPerLine, SavingSelection);
        if ok then
            UpdateWindowsMenuItem;
        with info^ do
            if SavingSelection and Replacing and (PictureType <> BlankField) and (PictureType <> FrameGrabberType)  then
                PictureType := Leftover;
    end;


    function SavePICTFile (fname: str255; vnum: integer; SavingSelection, NewFile: boolean): boolean;
        var
            f, err, i, v: integer;
            ByteCount, PICTSize: LongInt;
            PicH: PicHandle;
            fRect, frect2: rect;
            tPort: GrafPtr;
            TheInfo: FInfo;
            SaveInfoRec: PicInfo;
            HeaderSaved: boolean;
            SaveGDevice: GDHandle;

        procedure Abort;
        begin
            err := fsclose(f);
            if NewFile then
                err := FSDelete(fname, vnum);
            DisposeHandle(handle(PicH));
            {exit(SavePICTFile)}   {ppc-bug}
        end;

    begin
        with info^ do begin
                if OpPending then
                    KillRoi;
                SavePICTFile := false;
                ShowWatch;
                GetPort(tPort);
                if SavingSelection then
                    fRect := RoiRect
                else
                    SetRect(fRect, 0, 0, PixelsPerLine, nlines);
                with frect do
                    SetRect(frect2, 0, 0, right - left, bottom - top);
                with osPort^ do begin
                        SaveGDevice := GetGDevice;
                        SetGDevice(osGDevice);
                        SetPort(GrafPtr(osPort));
                        pmForeColor(BlackIndex);
                        pmBackColor(WhiteIndex);
                        if OldSystem then begin
                                RGBForeColor(BlackRGB);
                                RGBBackColor(WhiteRGB);
                            end;
                        ClipRect(PicRect);
                        LoadLUT(cTable);
                        PicH := OpenPicture(fRect2);
                        CopyBits(BitMapHandle(PortPixMap)^^, BitMapHandle(PortPixMap)^^, frect, frect2, SrcCopy, nil);
                        ClosePicture;
                        pmForeColor(ForegroundIndex);
                        pmBackColor(BackgroundIndex);
                    end;
                SetPort(tPort);
                SetGDevice(SaveGDevice);
                PICTSize := GetHandleSize(handle(PicH));
                if PICTSize <= 10 then begin
                        PutError('Sorry, but there is not enough memory available to save this PICT file. Try closing some windows, or save as TIFF.');
                        if NewFile then
                            err := FSDelete(fname, vnum);
                        DisposeHandle(handle(PicH));
                        exit(SavePICTFile)
                    end;
                err := fsopen(fname, vnum, f);
                err := SetFPos(f, FSFromStart, 0);
                SaveInfoRec := Info^;
                if (LutMode = GrayScale) or (LutMode = CustomGrayScale) then begin
                        nColors := 256;
                        ColorStart := 0;
                        ColorEnd := 255;
                        LUTMode := Grayscale;
                        IdentityFunction := true;
                    end;
                HeaderSaved := SaveHeader(f, 0, 0, vnum, fname, SavingSelection, false) = 0;
                Info^ := SaveInfoRec;
                if not HeaderSaved then begin
                    abort;
                    exit(SavePICTFile)
                end;
                err := fswrite(f, PICTSize, pointer(PicH^));
                if CheckIO(err) <> 0 then begin
                    abort;
                    exit(SavePICTFile)
                end;
                DisposeHandle(handle(PicH));
                ByteCount := PICTSize + HeaderSize;
                err := SetEOF(f, ByteCount);
                err := fsclose(f);
                err := GetFInfo(fname, vnum, TheInfo);
                if TheInfo.fdCreator <> 'Imag' then begin
                        TheInfo.fdCreator := 'Imag';
                        err := SetFInfo(fname, vnum, TheInfo);
                    end;
                if TheInfo.fdType <> 'PICT' then begin
                        TheInfo.fdType := 'PICT';
                        err := SetFInfo(fname, vnum, TheInfo);
                    end;
                err := FlushVol(nil, vnum);
                if not SavingSelection then begin
                        if (PictureType <> BlankField) and (PictureType <> FrameGrabberType)  and (PictureType <> NullPicture) then begin
                                PictureType := PictFile;
                                RemovePath(fname);
                                TruncateString(fname, maxTitle);
                                title := fname;
                                UpdateTitleBar;
                                vref := vnum;
                                revertable := true;
                                InvertedImage := false;
                            end;
                        Changes := false;
                    end;
            end; {with}
        SavePICTFile := true;
    end;


    procedure SaveAsPICT (fname: str255; RefNum: integer; SavingSelection: boolean);
        var
            f, err, i: integer;
            where: Point;
            TheInfo: FInfo;
            replacing, ok: boolean;
            name: str255;
    begin
        err := GetFInfo(fname, RefNum, TheInfo);
        case err of
            NoErr:
                with TheInfo do begin
                        if (fdType <> 'TIFF') and (fdType <> 'PICT') and (fdType <> 'IPIC') then begin
                                TypeMismatch(fname);
                                exit(SaveAsPICT)
                            end;
                        replacing := true;
                    end;
            FNFerr:  begin
                    err := create(fname, RefNum, 'Imag', 'PICT');
                    if CheckIO(err) <> 0 then
                        exit(SaveAsPICT);
                    replacing := false;
                end;
            otherwise
                if CheckIO(err) <> 0 then
                    exit(SaveAsPICT);
        end;
        ok := SavePICTFile(fname, RefNum, SavingSelection, not Replacing);
        if ok then
            UpdateWindowsMenuItem;
        with info^ do
            if SavingSelection and replacing and (PictureType <> BlankField) and (PictureType <> FrameGrabberType)  then
                PictureType := Leftover;
    end;


    procedure SaveSelection (fname: str255; RefNum: integer; SaveAsSameType: boolean);
        var
            slines, spixelsPerLine: integer;
    begin
        if info = NoInfo then
            exit(SaveSelection);
        if NoSelection or NotRectangular or NotInBounds then
            exit(SaveSelection);
        if OpPending then
            KillRoi;
        with info^ do begin
                with RoiRect do begin
                        sPixelsPerLine := right - left;
                        slines := bottom - top;
                    end;
                if (PictureType = PictFile) and SaveAsSameType and (SaveAsWhat <> asRawData) then
                    SaveAsPICT(fname, RefNum, true)
                else
                    SaveAsTIFF(fname, RefNum, sLines, sPixelsPerLine, true);
            end;
    end;


    procedure SaveAsText (fname: str255; RefNum: integer);
        var
            err, f: integer;
            TheInfo: FInfo;
            ByteCount: LongInt;
    begin
        err := GetFInfo(fname, RefNum, TheInfo);
        case err of
            NoErr:
                if TheInfo.fdType <> 'TEXT' then begin
                        TypeMismatch(fname);
                        exit(SaveAsText)
                    end;
            FNFerr:  begin
                    err := create(fname, RefNum, FourCharCode(TextCreator), 'TEXT');
                    if CheckIO(err) <> 0 then
                        exit(SaveAsText);
                end;
            otherwise
                if CheckIO(err) <> 0 then
                    exit(SaveAsTExt)
        end;
        ShowWatch;
        err := fsopen(fname, RefNum, f);
        if CheckIO(err) <> 0 then
            exit(SaveAsText);
        ByteCount := TextBufSize;
        err := fswrite(f, ByteCount, ptr(TextBufP));
        if CheckIO(err) <> 0 then
            exit(SaveAsText);
        err := SetEof(f, ByteCount);
        err := fsclose(f);
        err := FlushVol(nil, RefNum);
        if WhatsOnClip = TextOnClip then
            WhatsOnClip := NothingOnClip;
    end;


    procedure SaveAsPICS (fname: str255; fRefNum: integer);
        const
            rErr = 'Error Saving PICS file.';
        type
            PicHArray = array[1..MaxSlices] of PicHandle;
            PicHArrayPtr = ^PicHArray;
        var
            err: OSErr;
            TheInfo: FInfo;
            replacing: boolean;
            rRefNum, i, SaveCS: integer;
            frect: rect;
            {PicH: array[1..MaxSlices] of PicHandle;}
            PicH: PicHArrayPtr;
            MinFreeRequired: LongInt;
            SaveGDevice: GDHandle;
    begin
        with info^, Info^.StackInfo^ do begin
                if StackInfo = nil then begin
                        PutError('Only Stacks can be saved in PICS format.');
                        SaveAsWhat := asTiff;
                        exit(SaveAsPICS);
                    end;
                if ImageSize > MinFree then
                    MinFreeRequired := ImageSize
                else
                    MinFreeRequired := MinFree;
                if MaxBlock < MinFreeRequired then begin
                        PutError('Not enough memory available to save in PICS format.');
                        exit(SaveAsPICS);
                    end;
                PicH := PicHArrayPtr(NewPtr(SizeOf(PicHArray)));
                if PicH = nil then
                    exit(SaveAsPICS);
                err := GetFInfo(fname, fRefNum, TheInfo);
                if err = NoErr then
                    with TheInfo do begin
                            if (fdType <> 'TIFF') and (fdType <> 'PICT') and (fdType <> 'PICS') then begin
                                    TypeMismatch(fname);
                                    exit(SaveAsPICS)
                                end;
                            err := FSDelete(fname, fRefNum);
                        end;
                ShowWatch;
                err := SetVol(nil, fRefNum);
                CreateResFile(fname);
                if ResError <> NoErr then
                    exit(SaveAsPICS);
                rRefNum := OpenResFile(fname);
                SaveCS := CurrentSlice;
                SaveGDevice := GetGDevice;
                SetGDevice(osGDevice);
                SetPort(GrafPtr(osPort));
                with PicRect do
                    SetRect(frect, 0, 0, right - left, bottom - top);
                ClipRect(frect);
                LoadLUT(ctable);
                pmForeColor(BlackIndex);
                pmBackColor(WhiteIndex);
                if OldSystem then begin
                        RGBForeColor(BlackRGB);
                        RGBBackColor(WhiteRGB);
                    end;
                for i := 1 to nSlices do begin
                        CurrentSlice := i;
                        SelectSlice(CurrentSlice);
                        UpdateTitleBar;
                        PicH^[i] := OpenPicture(frect);
                        with osPort^ do
                            CopyBits(BitMapHandle(portPixMap)^^, BitMapHandle(portPixMap)^^, PicRect, frect, SrcCopy, nil);
                        ClosePicture;
                        if (PicH^[i] = nil) or ((PicH^[i] <> nil) and (GetHandleSize(handle(PicH^[i])) <= 10)) then begin
                                PutError(rErr);
                                leave;
                            end;
                        AddResource(handle(PicH^[i]), 'PICT', i - 1 + 128, '');
                        if ResError <> NoErr then begin
                                PutError(rErr);
                                leave;
                            end;
                        WriteResource(handle(PicH^[i]));
                        ReleaseResource(handle(PicH^[i]));
                        if ResError <> NoErr then begin
                                PutError(rErr);
                                leave;
                            end;
                    end; {for}
                pmForeColor(ForegroundIndex);
                pmBackColor(BackgroundIndex);
                SetGDevice(SaveGDevice);
                CurrentSlice := SaveCS;
                SelectSlice(CurrentSlice);
                RemovePath(fname);
                TruncateString(fname, maxTitle);
                title := fname;
                PictureType := PicsFile;
                UpdateTitleBar;
                CloseResFile(rRefNum);
                if ResError = NoErr then
                    changes := false
                else
                    PutError(rErr);
                err := GetFInfo(fname, fRefNum, TheInfo);
                TheInfo.fdType := 'PICS';
                TheInfo.fdCreator := 'Imag';
                err := SetFInfo(fname, fRefNum, TheInfo);
                err := FlushVol(nil, fRefNum);
                UpdateWindowsMenuItem;
            end; {with}
    end;


    function SuggestedName: str255;
        var
            name: str255;
    begin
        case SaveAsWhat of
            asTiff, asPict, asQuickTime, asRawData, asPICS:  begin
                    name := info^.title;
                    if name = 'Camera' then
                        name := 'Untitled';
                    SuggestedName := name;
                end;
            AsPalette:
                SuggestedName := 'Palette';
            AsOutline:
                SuggestedName := 'Outline';
        end;
    end;


    function SaveAsHook (item: integer; theDialog: DialogPtr): integer;
        const
            EditTextID = 7;
            TiffID = 9;
            OutlineID = 14;
        var
            i: integer;
            fname: str255;
            NameEdited: boolean;
    begin
        if item = -1 then {Initialize}
            SetDlogItem(theDialog, TiffID + ord(SaveAsWhat), 1);
        fname := GetDString(theDialog, EditTextID);
        NameEdited := fname <> SuggestedName;
        if (item >= TiffID) and (item <= OutlineID) then begin
                SaveAsWhat := SaveAsWhatType(item - TiffID);
                if not NameEdited then begin
                        SetDString(theDialog, EditTextID, SuggestedName);
                        SelectdialogItemText(theDialog, EditTextID, 0, 32767);
                    end;
                for i := TiffID to OutlineID do
                    SetDlogItem(theDialog, i, 0);
                SetDlogItem(theDialog, item, 1);
            end;
        SaveAsHook := item;
    end;


    procedure SaveAs (name: str255; RefNum: integer);
        const
            CustomDialogID = 60;
        var
            where: Point;
            reply: SFReply;
            isSelection: boolean;
            kind: integer;
    begin
        if SaveAsDHookProc=nil
            then SaveAsDHookProc:=NewRoutineDescriptor(@SaveAsHook, uppDlgHookProcInfo, GetCurrentISA);
        with info^ do begin
                if SaveAllState = SaveAllStage2 then begin
                        name := title;
                        RefNum := SaveRefNum;
                        if SaveAsWhat = AsPalette then
                            SaveAsWhat := AsTiff;
                    end
                else if (name = '') or ((RefNum = 0) and (pos(':', name) = 0)) then begin
                        where.v := 50;
                        where.h := 50;
                        if (StackInfo = nil) and (SaveAsWhat = asPICS) then
                            SaveAsWhat := asTIFF;
                        if (StackInfo <> nil) and (SaveAsWhat = asPICT) then
                            SaveAsWhat := asTIFF;
                        if name = '' then
                            name := SuggestedName;
                        SFPPutFile(Where, 'Save as?', name, SaveAsDHookProc, reply, CustomDialogID, nil);
                        if not reply.good then begin
                                SaveAllState := NoSaveAll;
                                AbortMacro;
                                exit(SaveAs);
                            end;
                        with reply do begin
                                name := fname;
                                RefNum := vRefNum;
                                DefaultRefNum := RefNum;
                            end;
                    end;
                if StackInfo <> nil then begin
                        if (SaveAsWhat <> asOutline) and not ((StackInfo^.StackType = RGBStack) and (StackInfo^.nSlices = 3)) then
                            KillRoi;
                        SaveAllState := NoSaveAll;
                        if not ((SaveAsWhat = asTIFF) or (SaveAsWhat = asQuickTime)  or (SaveAsWhat = asPICS) or (SaveAsWhat = asPalette) or (SaveAsWhat = asOutline)) then begin
                                PutError('Stacks can only be saved in TIFF, QuickTime or PICS format.');
                                SaveAsWhat := asTIFF;
                                exit(SaveAs);
                            end;
                    end;
                isSelection := RoiShowing and (RoiType = RectRoi);
                if SaveAllState = SaveAllStage1 then begin
                        SaveRefNum := RefNum;
                        SaveAllState := SaveAllStage2;
                    end;
                case SaveAsWhat of
                    asTiff, asRawData:
                        if isSelection then
                            SaveSelection(name, RefNum, false)
                        else
                            SaveAsTIFF(name, RefNum, 0, 0, false);
                    asPict:
                        if isSelection then
                            SaveAsPICT(name, RefNum, true)
                        else
                            SaveAsPICT(name, RefNum, false);
                    asQuickTime:
                        SaveAsQuickTime(name, RefNum);
                    asPICS:
                        SaveAsPICS(name, RefNum);
                    AsPalette:
                        SaveColorTable(name, RefNum);
                    AsOutline:
                        SaveOutline(name, RefNum);
                end; {case}
                if (SaveAsWhat = asRawData) and (SaveAllState <> SaveAllStage2) then
                    SaveAsWhat := asTIFF;
            end; {with}
    end;


    procedure SaveFile;
        var
            fname: str255;
            size: LongInt;
            ok: boolean;
    begin
        if CurrentWindow = ResultsKind then begin
                Export('', 0);
                exit(SaveFile);
            end;
        if CurrentWindow = TextKind then begin
                SaveText;
                exit(SaveFile);
            end;
        if OpPending then
            KillRoi;
        with Info^ do begin
                fname := title;
                size := 0;
                if PictureType = TiffFile then
                    ok := SaveTiffFile(fname, vref, 0, 0, false)
                else if PictureType = PictFile then
                    ok := SavePICTFile(fname, vref, false, false)
                else
                    SaveAs('', 0);
            end;
    end;


    function SaveChanges: integer;
        const
            yesID = 1;
            noID = 2;
            cancelID = 3;
        var
            id: integer;
            reply: SFReply;
    begin
        id := 0;
        if info^.changes then
            with info^ do begin
                    if CommandPeriod or MakingStack or (macro and ((MacroCommand = DisposeC) or (MacroCommand = DisposeAllC))) then begin
                            SaveChanges := ok;
                            exit(SaveChanges);
                        end;
                    ParamText(title, '', '', '');
                    InitCursor;
                    id := alert(600, nil);
                    if id = yesID then begin
                            KillRoi;
                            SaveFile;
                            InitCursor;
                        end; {if yes}
                end; {if changes}
        if (id = cancelID) or ((id = yesID) and (info^.changes)) then
            SaveChanges := cancel
        else
            SaveChanges := ok;
    end;


    function CloseAWindow (WhichWindow: WindowPtr): integer;
        var
            i, kind, n: integer;
            TempInfo: InfoPtr;
            TempTextInfo: TextInfoPtr;
            SizeStr, str: str255;
            wp: ^WindowPtr;
            pcrect: rect;
    begin
        if WhichWindow = nil then
            exit(CloseAWindow);
        kind := WindowPeek(WhichWindow)^.WindowKind;
        CloseAWindow := ok;
        if WhichWindow = VideoControl then begin
                DisposeDialog(VideoControl);
                VideoControl := nil;
                exit(CloseAWindow);
            end;
        case kind of
            PicKind:  begin
                    Info := pointer(WindowPeek(WhichWindow)^.RefCon);
                    with Info^ do begin
                            if PicNum = 0 then begin
                                    beep;
                                    exit(CloseAWindow);
                                end;
                            if SaveChanges = cancel then begin
                                    CloseAWindow := cancel;
                                    exit(CloseAWindow)
                                end;
                            DeleteMenuItem(WindowsMenuH, PicNum + WindowsMenuItems + nTextWindows);
                            for i := PicNum to nPics - 1 do begin
                                    PicWindow[i] := PicWindow[i + 1];
                                    TempInfo := pointer(WindowPeek(PicWindow[i])^.RefCon);
                                    TempInfo^.PicNum := i
                                end;
                            if PictureType = BlankField then
                                BlankFieldInfo := nil;
                            if (PictureType = FrameGrabberType) and (FrameGrabber = QTvdig) then
                                CloseVdig;
                            if StackInfo <> nil then begin
                                    with StackInfo^ do
                                        for i := 1 to nSlices do
                                            DisposeHandle(PicBaseH[i]);
                                    DisposePtr(pointer(StackInfo));
                                end
                            else begin
                                    if not MakingStack then
                                        DisposeHandle(PicBaseHandle);
                                end;
                            DisposeWindow(WhichWindow);
                            CloseCPort(osPort);
                            DisposePtr(ptr(osPort));
                            DisposeRgn(roiRgn);
                            if DataH <> nil then
                                    DisposeHandle(DataH);
                            nPics := nPics - 1;
                            OpPending := false;
                            isInsertionPoint := false;
                            DisposePtr(pointer(Info));
                            Info := NoInfo;
                            if (nPics = 0) and (not finished) then
                                with info^ do begin
                                        LoadLUT(info^.cTable);
                                        if (LutMode = GrayScale) or (LutMode = CustomGrayScale) then
                                            DrawMap;
                                    end;
                            PicLeft := PicLeftBase;
                            PicTop := PicTopBase;
                        end;
                end; {PicKind}
            HistoKind:  begin
                    DisposeWindow(HistoWindow);
                    HistoWindow := nil;
                    ContinuousHistogram := false;
                end;
            ProfilePlotKind, CalibrationPlotKind:  begin
                    DisposeWindow(PlotWindow);
                    PlotWindow := nil;
                    KillPicture(PlotPICT);
                    PlotPICT := nil;
                end;
            ResultsKind:  begin
                    DisposeWindow(ResultsWindow);
                    ResultsWindow := nil;
                    TEDispose(ListTE);
                end;
            TextKind:  begin
                    TextInfo := TextInfoPtr(WindowPeek(WhichWindow)^.RefCon);
                    if TextInfo <> nil then
                        with TextInfo^ do begin
                                if SaveTextChanges = cancel then begin
                                        CloseAWindow := cancel;
                                        exit(CloseAWindow)
                                    end;
                                DisposeWindow(TextWindowPtr);
                                DeleteMenuItem(WindowsMenuH, WindowsMenuItems - 1 + WindowNum);
                                TEDispose(TextTE);
                                DisposePtr(ptr(TextInfo));
                                TextInfo := nil;
                                for i := WindowNum to nTextWindows - 1 do begin
                                        TextWindow[i] := TextWindow[i + 1];
                                        TempTextInfo := pointer(WindowPeek(TextWindow[i])^.RefCon);
                                        TempTextInfo^.WindowNum := i
                                    end;
                                nTextWindows := nTextWindows - 1;
                            end;
                end;
            PasteControlKind:  begin
                    GetWindowRect(PasteControl, pcrect);
                    with pcrect do begin
                            PasteControlLeft := left;
                            PasteControlTop := top;
                        end;
                    DisposeWindow(PasteControl);
                    PasteControl := nil;
                    wp := pointer(GhostWindow);
                    wp^ := nil;
                end;
            otherwise
                ;
        end; {case}
    end;


    procedure DoClose;
        var
            ignore: integer;
            fwptr: WindowPtr;
            kind: integer;
    begin
        fwptr := FrontWindow;
        if fwptr <> nil then begin
                if fwptr = VideoControl then begin
                        DisposeDialog(VideoControl);
                        VideoControl := nil;
                        exit(DoClose);
                    end;
                kind := WindowPeek(fwptr)^.WindowKind;
                if (kind = PicKind) or (kind = ProfilePlotKind) or (kind = CalibrationPlotKind) or (kind = HistoKind) or (Kind = PasteControlKind) or (Kind = ResultsKind) or (Kind = TextKind) then
                    ignore := CloseAWindow(fwptr);
            end;
    end;


    procedure Read4BitTIFF (f: integer);
        var
            vloc, hloc, i: integer;
            ByteCount, count: LongInt;
            err: OSErr;
            UnpackedLine, PackedLine: LineType;
    begin
        with info^ do begin
                if PixelsPerLine > MaxLine then
                    exit(Read4BitTIFF);
                ByteCount := (PixelsPerLine + 1) div 2;
                for vloc := 0 to nLines - 1 do begin
                        err := FSRead(f, ByteCount, @PackedLine);
                        i := 0;
                        for hloc := 0 to PixelsPerLine - 1 do
                            if odd(hloc) then begin
                                    UnpackedLine[hloc] := bsl(band(PackedLine[i], $F), 4);
                                    i := i + 1;
                                end
                            else
                                UnpackedLine[hloc] := band(PackedLine[i], $F0);
                        PutLine(0, vloc, PixelsPerLine, UnpackedLine);
                    end;
            end; {with}
    end;


{$POP}

    procedure CheckFileSize(f:integer; var size: LongInt; offset: LongInt);
    {Check to make sure we don't read past the end of file.}
    var
        FileSize: LongInt;
        err: OSErr;
    begin
        err := GetEof(f, FileSize);
        if (offset + size) > FileSize then begin
           size := FileSize - offset;
           if size < 0 then size := 0;
        end;
    end;


    procedure ReadStackSlices (f, nExtraImages: integer; var table: TiffIFDTablePtr);
        var
            i, err, SaveCS: integer;
            h: handle;
            DataSize: LongInt;
            PartialStack: boolean;
    begin
        ShowMessage(CmdPeriodToStop);
        PartialStack := false;
        with info^ do begin
                StackInfo := StackInfoPtr(NewPtr(SizeOf(StackInfoRec)));
                if StackInfo = nil then
                    exit(ReadStackSlices);
            end;
        with info^, info^.StackInfo^ do begin
                nSlices := nExtraImages + 1;
                CurrentSlice := TempStackInfo.CurrentSlice;
                if (CurrentSlice < 1) or (CurrentSlice > nSlices) then
                    CurrentSlice := 1;
                SliceSpacing := TempStackInfo.SliceSpacing;
                FrameInterval := TempStackInfo.FrameInterval;
                StackType := TempStackInfo.StackType;
                SaveCS := CurrentSlice;
                PicBaseH[1] := PicBaseHandle;
                revertable := false;
                for i := 2 to nSlices do begin
                        h := GetBigHandle(PixMapSize);
                        if h = nil then begin
                                nSlices := i - 1;
                                PutError(concat('Not enough memory to open all ', long2str(nExtraImages + 1), ' slices in the stack.'));
                                PartialStack := true;
                                leave;
                            end;
                        PicBaseH[i] := h;
                        CurrentSlice := i;
                        SelectSlice(i);
                        UpdateTitleBar;
                        DataSize := ImageSize;
                        err := SetFPos(f, fsFromStart, table^[i - 1].offset);
                        CheckFileSize(f, DataSize, table^[i - 1].offset);
                        if DataSize > 0 then
                            err := fsread(f, DataSize, h^);
                        if odd(PixelsPerLine) then
                            UnpackLines;
                        if InvertedImage then
                            InvertPic;
                        UpdatePicWindow;
                        if CommandPeriod then begin
                                beep;
                                if i < nSlices then
                                    PartialStack := true;
                                nSlices := i;
                                wait(60);
                                leave;
                            end;
                    end; {for}
                CurrentSlice := SaveCS;
                if CurrentSlice > nSlices then
                    CurrentSlice := 1;
                SelectSlice(CurrentSlice);
                if PartialStack then begin
                        vref := 0;
                        PictureType := NewPicture;
                        title := concat(title, '@');
                    end;
                UpdateTitleBar;
                UpdateWindowsMenuItem;
            end;
    end;


    procedure OpenStack (f: integer);
        var
            table: TiffIFDTablePtr;
            i, nExtraImages: integer;
            where: LongInt;
    begin
        table := TiffIFDTablePtr(NewPtr(SizeOf(TiffIFDTable)));
        if table = nil then
            exit(OpenStack);
        nExtraImages := TempStackInfo.nSlices - 1;
        with info^ do begin
                where := ImageDataOffset;
                for i := 1 to nExtraImages do
                    with table^[i] do begin
                            iWidth := PixelsPerLine;
                            iHeight := nLines;
                            where := where + ImageSize;
                            Offset := where;
                            invert := false;
                        end;
                ReadStackSlices(f, nExtraImages, table);
            end;
    end;


    procedure OpenExtraTiffImages (f: integer; NextTiffIFD: LongInt);
        var
            table: TiffIFDTablePtr;
            TiffInfo: TiffInfoRec;
            i, nExtraImages: integer;
            AllSameSize: boolean;
    begin
        table := TiffIFDTablePtr(NewPtr(SizeOf(TiffIFDTable)));
        if table = nil then
            exit(OpenExtraTiffImages);
        nExtraImages := 0;
        repeat
            if not OpenTiffDirectory(f, NextTiffIFD, TiffInfo, false) then
                exit(OpenExtraTiffImages);
            nExtraImages := nExtraImages + 1;
            with TiffInfo, table^[nExtraImages] do begin
                    iWidth := width;
                    iHeight := height;
                    Offset := OffsetToData;
                    invert := ZeroIsBlack;
                    NextTiffIFD := NextIFD;
                end;
        until (NextTiffIFD = 0) or (nExtraImages = MaxSlices);
        AllSameSize := true;
        with info^ do begin
                for i := 1 to nExtraImages do
                    AllSameSize := AllSameSize and (PixelsPerLine = table^[i].iWidth) and (nLines = table^[i].iHeight);
                if AllSameSize and not odd(PixelsPerLine) then
                    ReadStackSlices(f, nExtraImages, table);
            end;
    end;

    procedure OpenPlanarRGBTiff(f: integer);
    var
        row, ignore, SaveRow: integer;
        NextUpdate, count: LongInt;
        rLine, gLine, bLine: LineType;
        err: OSErr;
        MaskRect: rect;
    begin
        with info^ do begin
            err := SetFPos(f, fsFromStart, ImageDataOffset);
            SelectSlice(1);
            for row:=0 to nLines - 1 do begin
                count := PixelsPerLine;
                err := fsread(f, count, @rLine);
                PutLine(0, row, PixelsPerLine, rLine);
            end;
            InvertPic;
            ResetGrayMap;
            UpdatePicWindow;
            SelectSlice(2);
            for row:=0 to nLines - 1 do begin
                count := PixelsPerLine;
                err := fsread(f, count, @gLine);
                PutLine(0, row, PixelsPerLine, gLine);
            end;
            InvertPic;
            UpdatePicWindow;
            SelectSlice(3);
            for row:=0 to nLines - 1 do begin
                count := PixelsPerLine;
                err := fsread(f, count, @bLine);
                PutLine(0, row, PixelsPerLine, bLine);
            end;
            InvertPic;
            UpdatePicWindow;
            with StackInfo^ do begin
                CurrentSlice := 1;
                SelectSlice(CurrentSlice);
                StackType := rgbStack;
            end;
            UpdateTitleBar;
            OpeningRGB := true;
        end; {with}
    end;


    procedure OpenRGBTiff(f: integer; TiffInfo: TiffInfoRec);
    const
        bufsize = 12000;
    var
        i, row, pixel, rgbPixel, ignore, SaveRow: integer;
        NextUpdate, count: LongInt;
        buffer: packed array [0 .. bufsize] of byte;
        rLine, gLine, bLine: LineType;
        err: OSErr;
        MaskRect: rect;
    begin
        with info^ do begin
            if PixelsPerLine > MaxLine then
                exit(OpenRGBTiff);
            if not MakeStackFromWindow then
                exit(OpenRGBTiff);
            if not AddSlice(false) then begin
                    info^.changes := false;
                    ignore := CloseAWindow(info^.wptr);
                    exit(OpenRGBTiff);
                end;
            if not AddSlice(false) then begin
                    info^.changes := false;
                    ignore := CloseAWindow(info^.wptr);
                    exit(OpenRGBTiff);
                end;
            if TiffInfo.PlanarConfig <> 1 then begin
                OpenPlanarRGBTiff(f);
                exit(OpenRGBTiff);
            end;
            if ScreenDepth <> 8 then begin
                SelectAll(false);
                DoOperation(EraseOp);
                changes:= false;
                KillRoi;
            end;
            ResetGrayMap;
            SaveRow:=0;
            NextUpdate:=TickCount+6;
            err := SetFPos(f, fsFromStart, ImageDataOffset);
            count := 0;
            for row:=0 to nLines - 1 do begin
                for pixel := 0 to PixelsPerLine - 1 do begin
                    if count <= 0 then begin
                        count := bufsize;
                        err := fsread(f, count, @buffer);
                        if err <> -39 then {eof error}
                            if CheckIO(err) <> noErr then
                                exit(OpenRGBTiff);
                        rgbPixel := 0;
                    end;
                    rLine[pixel] := 255 - buffer[rgbPixel];
                    gLine[pixel] := 255 - buffer[rgbPixel + 1];
                    bLine[pixel] := 255 - buffer[rgbPixel + 2];
                    rgbPixel := rgbPixel + 3;
                    count := count - 3;
                end;
                SelectSlice(1);
                PutLine(0, row, PixelsPerLine, rLine);
                if TickCount>=NextUpdate then begin
                    SetRect(MaskRect, 0, SaveRow, PixelsPerLine, row+1);
                    UpdateScreen(MaskRect);
                    SaveRow:=row + 1;
                    NextUpdate:=TickCount+6;
                end;
                SelectSlice(2);
                PutLine(0, row, PixelsPerLine, gLine);
                SelectSlice(3);
                PutLine(0, row, PixelsPerLine, bLine);
            end; {for}
            with StackInfo^ do begin
                CurrentSlice := 1;
                SelectSlice(CurrentSlice);
                StackType := rgbStack;
            end;
            SetRect(MaskRect, 0, SaveRow, PixelsPerLine, nLines);
            UpdateScreen(MaskRect);
            UpdateTitleBar;
            OpeningRGB := true;
        end; {with}
    end;


    function OpenFile (fname: str255; vnum: integer): boolean;
        var
            ticks, ByteCount, i, DataSize, NextTiffIFD: LongInt;
            err: OSErr;
            f: integer;
            line, pixel: integer;
            iptr, p: ptr;
            SaveInfo: InfoPtr;
            TiffInfo: TiffInfoRec;
            isRGBTiff: boolean;
    begin
        OpenFile := false;
        ShowWatch;
        err := fsopen(fname, vNum, f);
        SaveInfo := Info;
        iptr := NewPtr(SizeOf(PicInfo));
        if iptr = nil then begin
                PutMemoryAlert;
                err := fsclose(f);
                exit(OpenFile)
            end;
        Info := pointer(iptr);
        CloneInfo(SaveInfo^, Info^);
        with Info^ do begin
                ColorMapOffset := 0;
                if not OpenHeader(f, fname, vnum, TiffInfo) then begin
                        DisposePtr(iptr);
                        err := fsclose(f);
                        Info := SaveInfo;
                        exit(OpenFile)
                    end;
                if WhatToOpen = OpenTIFF then begin
                    NextTiffIFD := TiffInfo.NextIFD;
                    isRGBTiff := TiffInfo.SamplesPerPixel = 3;
                end else begin
                    NextTiffIFD := 0;
                    isRGBTiff := false;
                end;
                p := GetImageMemory(SaveInfo);
                if p = nil then begin
                        err := fsclose(f);
                        exit(OpenFile)
                    end;
                PicBaseAddr := p;
                MakeNewWindow(fname);
                err := SetFPos(f, fsFromStart, ImageDataOffset);
                if PictureType = FourBitTIFF then
                    Read4BitTIFF(f)
                else if not isRGBTiff then begin
                        DataSize := nlines * PixelsPerLine;
                        CheckFileSize(f, DataSize, ImageDataOffset);
                        if DataSize > 0 then
                            err := fsread(f, DataSize, PicBaseAddr);
                        if CheckIO(err) <> NoErr then begin
                                err := fsclose(f);
                                exit(OpenFile)
                            end;
                    end;
                if odd(PixelsPerLine) and (PictureType <> FourBitTiff) then
                    UnpackLines;
                if (PictureType = Imported) and (ImportInvert or (WhatToImport = ImportMCID)) then
                    InvertedImage := true;
                if InvertedImage then
                    InvertPic;
                if PictureType = FourBitTIFF then
                    PictureType := imported;
                if (ColorMapOffset > 0) and (fileVersion = 0) then begin
                        FixColors; {Fix colors, if necessary, of imported color TIFF files.}
                        WhatToUndo := NothingToUndo;
                    end;
                vref := vnum;
                if PixMapSize > UndoBufSize then
                    PutWarning;
                revertable := true;
            end; {with}
            if isRGBTiff then
                OpenRGBTiff(f, TiffInfo)
            else if TempStackInfo.nSlices > 0 then
                OpenStack(f)
            else if NextTiffIFD > 0 then
            OpenExtraTiffImages(f, NextTiffIFD);
        err := fsclose(f);
        OpenFile := true;
    end;


{$PUSH}
{$D-}

    procedure ScaleToEightBits (f: integer);
        type
            PixelLUTType = packed array[0..65535] of byte;
            PixelLUTPtr = ^PixelLUTType;
            IntLineType = array[0..MaxLine] of integer;
        var
            line: LineType;
            i, j, value, LineSize, offset: LongInt;
            ScaleFactor: extended;
            hloc, vloc, wwidth, wheight, IntValue, SaveBytesPerRow: integer;
            PixelLUT: PixelLUTPtr;
            str1, str2: str255;
            err: integer;
            aLine: IntLineType;
            LinesPerUpdate: integer;

        procedure reset;
            var
                DataSize, SliceOffset: LongInt;
                p: ptr;
        begin
            with info^ do begin
                    if StackInfo <> nil then
                        SliceOffset := ImageSize * 2 * (StackInfo^.CurrentSlice - 1)
                    else
                        SliceOffset := 0;
                    err := SetFPos(f, fsFromStart, ImageDataOffset + SliceOffset);
                    if DataH <> nil then begin
                            if offset = -1 then begin
                                    hlock(DataH);
                                    DataSize := ImageSize * 2;
                                    CheckFileSize(f, DataSize, ImageDataOffset);
                                    if DataSize > 0 then
                                        err := fsread(f, DataSize, DataH^);
                                end;
                            offset := 0
                        end;
                end;
        end;


        procedure GetIntLine (var line: IntLineType);
            type
                atype = packed array[1..2] of char;
            var
                p: ptr;
                a: atype;
                c: char;
                i: integer;
        begin
            with info^ do begin
                    if DataH <> nil then begin
                            p := ptr(ord4(DataH^) + offset);
                            if (offset + LineSize) <= (PixMapSize * 2) then
                                BlockMove(p, @line, LineSize);
                            offset := offset + LineSize;
                        end
                    else
                        err := fsread(f, LineSize, @line);
                    if LittleEndian then
                        for i := 0 to LineSize div 2 - 1 do begin
                                a := atype(line[i]);
                                c := a[1];
                                a[1] := a[2];
                                a[2] := c;
                                line[i] := integer(a)
                            end;
                end;
        end;

        procedure FindMinAndMax;
        var
            vloc, hloc: integer;
            value: LongInt;
        begin
            with info^ do begin
                AbsoluteMin := 999999;
                AbsoluteMax := -999999;
                for vloc := 0 to nlines - 1 do begin
                        if (vloc mod LinesPerUpdate) = 0 then
                            ShowAnimatedWatch;
                        GetIntLine(aLine);
                        for hloc := 0 to PixelsPerLine - 1 do begin
                                value := aLine[hloc];
                                if (DataType = SixteenBitsUnsigned) and (value < 0) then
                                    value := value + 65536;
                                if value > AbsoluteMax then
                                    AbsoluteMax := value;
                                if value < AbsoluteMin then begin
                                    if ImportingDicom then begin
                                        if value <> -32767 then AbsoluteMin := value
                                    end else
                                        AbsoluteMin := value;
                                end; {value <AbsoluteMin}
                            end {for hloc:=}
                    end;{for vloc := }
                if (CurrentMin = 0) and (CurrentMax = 0) then begin
                        CurrentMin := AbsoluteMin;
                        CurrentMax := AbsoluteMax;
                    end;
                reset;
            end; {with}
        end;

    begin
        with info^ do begin
                PixelLUT := PixelLUTPtr(NewPtr(SizeOf(PixelLUTType)));
                if PixelLUT = nil then begin
                        if DataH <> nil then begin
                                DisposeHandle(DataH);
                                DataH := nil
                            end;
                        PutError('Not enough memory to do 16 to 8-bit scaling.');
                        AbortMacro;
                        exit(ScaleToEightBits);
                    end;
                offset := -1;
                reset;
                LineSize := PixelsPerLine * 2;
                LinesPerUpdate := 40000 div LineSize;
                if (AbsoluteMin = 0) and (AbsoluteMax = 0) then
                    FindMinAndMax;
                str1 := concat('min=', long2str(CurrentMin), ' (', long2str(AbsoluteMin), ')', crStr, 'max=', long2str(CurrentMax), ' (', long2str(AbsoluteMax), ')');
                ScaleFactor := 253.0 / (CurrentMax - CurrentMin);
                RealToString(ScaleFactor, 1, 4, str2);
                ShowMessage(concat(str1, crStr, 'scale factor= ', str2));
                j := 0;
                for i := CurrentMin to CurrentMax do begin
                        PixelLUT^[j] := round((i - CurrentMin) * ScaleFactor + 1);
                        j := j + 1;
                    end;
                for vloc := 0 to nlines - 1 do begin
                        if (vloc mod LinesPerUpdate) = 0 then
                            ShowAnimatedWatch;
                        GetIntLine(aLine);
                        for hloc := 0 to PixelsPerLine - 1 do begin
                                value := aLine[hloc];
                                if (DataType = SixteenBitsUnsigned) and (value < 0) then
                                    value := value + 65536;
                                if value < CurrentMin then
                                    value := CurrentMin;
                                if value > CurrentMax then
                                    value := CurrentMax;
                                line[hloc] := PixelLUT^[value - CurrentMin];
                                i := i + 1;
                            end;
                        PutLine(0, vloc, PixelsPerLine, line);
                    end;
                if fit = StraightLine then begin
                        nCoefficients := 2;
                        coefficient[2] := (CurrentMin - CurrentMax) / 253.0;
                        coefficient[1] := CurrentMax - coefficient[2];
                        nKnownValues := 0;
                        ZeroClip := false;
                    end;
                DisposePtr(ptr(PixelLUT));
                if DataH <> nil then begin
                        DisposeHandle(DataH);
                        DataH := nil
                    end;
                UpdateTitleBar;
            end; {with}
    end;


    procedure RescaleToEightBits;
        var
            range: LongInt;
            err: OSErr;
            f: integer;
    begin
        with info^ do begin
                ShowWatch;
                KillRoi;
                DisableDensitySlice;
                err := fsopen(title, vref, f);
                if CheckIO(err) <> 0 then
                    exit(RescaleToEightBits);
                range := CurrentMax - CurrentMin;
                if ColorStart > 0 then
                    CurrentMax := CurrentMax - round((ColorStart / 255.0) * range)
                else
                    CurrentMax := AbsoluteMax;
                if ColorEnd < 255 then
                    CurrentMin := CurrentMin + round(((255 - ColorEnd) / 255.0) * range)
                else
                    CurrentMin := AbsoluteMin;
                ScaleToEightBits(f);
                err := fsclose(f);
                InvertPic;
                UpdatePicWindow;
                ResetMap;
                if fit <> uncalibrated then
                    GenerateValues;
            end;
    end;


    procedure Import16BitSlices (f: integer);
        var
            i, err: integer;
            h: handle;
            DataSize, nImages, MaxImages, FileSize: LongInt;
    begin
        with info^ do begin
                nImages := ImportCustomSlices;
                err := GetEof(f, FileSize);
                MaxImages := (FileSize - ImportCustomOffset) div (ImageSize * 2);
                if nImages > MaxImages then
                    nImages := MaxImages;
                if nImages < 2 then
                    exit(Import16BitSlices);
                ShowMessage(CmdPeriodToStop);
                StackInfo := StackInfoPtr(NewPtr(SizeOf(StackInfoRec)));
                if StackInfo = nil then
                    exit(Import16BitSlices);
            end; {with}
        with info^, info^.StackInfo^ do begin
                nSlices := nImages;
                SliceSpacing := 0.0;
                FrameInterval := 0.0;
                StackType := VolumeStack;
                PicBaseH[1] := PicBaseHandle;
                revertable := false;
                for i := 2 to nSlices do begin
                        h := NewHandle(PixMapSize);
                        if h = nil then begin
                                nSlices := i - 1;
                                leave;
                            end;
                        PicBaseH[i] := h;
                        CurrentSlice := i;
                        SelectSlice(i);
                        UpdateTitleBar;
                        DataSize := ImageSize;
                        AbsoluteMin := 0;
                        AbsoluteMax := 0;
                        CurrentMin := 0;
                        CurrentMax := 0;
                        if not ImportAutoScale then begin
                                if ((ImportMax - ImportMin) > 65536.0) or (ImportMin > ImportMax) then begin
                                        ImportMin := 0.0;
                                        ImportMax := 255;
                                    end;
                                CurrentMin := round(ImportMin);
                                CurrentMax := round(ImportMax);
                            end;
                        ScaleToEightBits(f);
                        InvertPic;
                        UpdatePicWindow;
                        if CommandPeriod then begin
                                beep;
                                nSlices := i;
                                wait(60);
                                leave;
                            end;
                    end; {for}
                if (MaxBlock < MinFree) and (nSlices > 1) then begin
                        repeat
                            DisposeHandle(PicBaseH[nSlices]);
                            nSlices := nSlices - 1;
                        until (MaxBlock > MinFree) or (nSlices = 1);
                        PutError(concat('Not enough memory to open all ', long2str(nImages), ' slices in the stack.'));
                    end;
                CurrentSlice := 1;
                SelectSlice(CurrentSlice);
                if ImportCalibrate and  ImportAutoScale then begin
                    RemoveDensityCalibration;
                    ImportCalibrate := false;
                end;
                UpdateTitleBar;
                UpdateWindowsMenuItem;
            end;
    end;


    function Import16BitFile (fname: str255; vnum: integer): boolean;
        var
            ticks, ByteCount, i: LongInt;
            err: OSErr;
            f: integer;
            line, pixel: integer;
    begin
        Import16BitFile := false;
        if ImportCustomWidth > MaxLine then
            exit(Import16BitFile);
        if not NewPicWindow(fname, ImportCustomWidth, ImportCustomHeight) then
            exit(Import16BitFile);
        ShowWatch;
        err := fsopen(fname, vNum, f);
        with info^ do begin
                PictureType := imported;
                ImageDataOffset := ImportCustomOffset;
                DataType := ImportCustomDepth;
                vref := vnum;
                AbsoluteMin := 0;
                AbsoluteMax := 0;
                CurrentMin := 0;
                CurrentMax := 0;
                LittleEndian := ImportSwapBytes;
                if ImportCalibrate then begin
                    fit := StraightLine;
                    nCoefficients := 2;
                    coefficient[1] := 0.0; {ScaleToEightBits changes these coefficient}
                    coefficient[2] := 1.0;
                end else
                    RemoveDensityCalibration;
                if not ImportAutoScale then begin
                        if ((ImportMax - ImportMin) > 65536.0) or (ImportMin > ImportMax) then begin
                                ImportMin := 0.0;
                                ImportMax := 255;
                            end;
                        CurrentMin := round(ImportMin);
                        CurrentMax := round(ImportMax);
                    end;
                DataH := GetBigHandle(PixMapSize * 2);
                ScaleToEightBits(f);
                if ImportCustomSlices > 1 then
                    Import16BitSlices(f);
                err := fsclose(f);
                InvertPic;
                if PixMapSize > UndoBufSize then
                    PutWarning;
                revertable := false;
            end; {with}
        Import16BitFile := true;
    end;


    procedure InitPictBuffer (howBig: LongInt);
    begin
        repeat
            PictBuffer := NewPtr(howBig);
            if PictBuffer = nil then
                howBig := howBig div 2;
        until PictBuffer <> nil;
        DisposePtr(PictBuffer);
        PictBuffer := NewPtr(howBig div 2);
    end;


    procedure FillPictBuffer;
        var
            count: LongInt;
            err: OSErr;
    begin
        count := GetPtrSize(PictBuffer);
        if not fitsInPictBuffer then begin
                err := FSRead(PictF, count, PictBuffer);
                if err <> NoErr then
                    PictReadErr := true;
            end;
        bytesInPictBuffer := count;
        curPictBufPtr := PictBuffer;
    end;


    procedure GetPICTData (dataPtr: Ptr; byteCount: Integer);
    {Input picture spooler routine taken from Apple's PICTViewer example program.}
        var
            count: LongInt;
            anErr: OSErr;
    begin
        count := byteCount;
        repeat
            if bytesInPictBuffer >= count then begin
                    BlockMove(curPictBufPtr, dataPtr, count);
                    curPictBufPtr := Ptr(Ord4(curPictBufPtr) + count);
                    bytesInPictBuffer := bytesInPictBuffer - count;
                    count := 0;
                end
            else begin        {Not enough in buffer}
                    if bytesInPictBuffer > 0 then begin
                            BlockMove(curPictBufPtr, dataPtr, bytesInPictBuffer);
                            dataPtr := Ptr(Ord4(dataPtr) + bytesInPictBuffer);
                            count := count - bytesInPictBuffer;
                        end;
                    FillPictBuffer;
                end;
        until count = 0;
    end;


    procedure BitInfo (var srcBits: PixMap; var srcRect, dstRect: rect; mode: integer; maskRgn: rgnHandle);
        var
            i, size: integer;
    begin
        if BitInfoCount = 0 then begin
                PictSrcRect := srcRect;
                if srcBits.rowBytes < 0 then
                    with srcBits.pmTable^^ do begin {Make sure it is a PixMap.}
                            size := ctSize;
                            if size > 255 then
                                size := 255;
                            if size > 0 then begin
                                    BitInfoCount := BitInfoCount + 1;
                                    if not UseExistingLUT then
                                        with info^ do begin
                                                for i := 0 to size do
                                                    cTable[i].rgb := ctTable[i].rgb;
                                                LutMode := ColorLut;
                                                SetupPseudocolor;
                                            end;
                                end;
                        end; {with}
            end;
    end;


    procedure GetLUTFromPict (thePict: PicHandle);
  {Refer to "Screen Dump FKEY for Color Picts", February 1988 MacTutor.}
        type
            myPicData = record
                    p: Picture;
                    ID: integer
                end;
            myPicPtr = ^myPicData;
            myPicHdl = ^myPicPtr;
        var
            tempProcs: CQDProcs;
            SavePort: GrafPtr;
            err: osErr;
            TempPort: CGrafPort;
            limbo: rect;
            xxscale, yyscale: extended;
    begin
        GetPort(SavePort);
        OpenCPort(@TempPort);
        SetStdCProcs(tempProcs);
        tempProcs.bitsProc := BitInfoProc;
        tempProcs.getPicProc := GetPICTDataProc;
        PictSrcRect := thePict^^.picFrame;
        BitInfoCount := 0;
        TempPort.grafProcs := @tempProcs;
        err := SetFPos(PictF, fsFromStart, 512 + SizeOf(Picture));
        FillPictBuffer;
        limbo := thePict^^.picFrame;
        OffsetRect(limbo, 10000, 10000);
        if not PictReadErr then
            DrawPicture(thePict, limbo);
        CloseCPort(@TempPort);
        SetPort(SavePort);
        with info^, PictSrcRect do begin
                LoadLUT(cTable);
                xxScale := (right - left) / PixelsPerLine;
                yyScale := (bottom - top) / nLines;
                if (xxScale > 1.0) and ((PixelsPerLine * xxScale) <= MaxLine) and ((xxScale - yyScale) < 0.1) then begin
                        PixelsPerLine := right - left;
                        nLines := bottom - top;
                    end;
            end; {with}
    end;


    function OpenPict;{(fname:str255; vnum:integer; Reverting:boolean):boolean}
        var
            err: OSErr;
            i: integer;
            iptr, p: ptr;
            PictSize, HowBig: LongInt;
            thePict: PicHandle;
            tPort: GrafPtr;
            tempProcs: CQDProcs;
            SaveProcsPtr: QDProcsPtr;
            SaveInfo: InfoPtr;
            SaveGDevice: GDHandle;
            TiffInfo: TiffInfoRec;

        procedure Abort;
        begin
            if not reverting then begin
                    DisposePtr(pointer(Info));
                    Info := SaveInfo;
                    LoadLUT(info^.cTable);
                end;
            if thePict <> nil then
                DisposeHandle(handle(thePict));
            if PictF <> 0 then
                err := fsclose(PictF);
            {exit(OpenPict);} {ppc-bug}
        end;

    begin
        if BitInfoProc=nil
            then BitInfoProc:=NewRoutineDescriptor(@BitInfo, uppQDBitsProcInfo, GetCurrentISA);
        if GetPictDataProc=nil
            then GetPictDataProc:=NewRoutineDescriptor(@GetPictData, uppQDGetPicProcInfo, GetCurrentISA);
        PictF := 0;
        thePict := nil;
        OpenPict := false;
        PictReadErr := false;
        ShowWatch;
        SaveInfo := Info;
        err := fsopen(fname, vNum, PictF);
        if CheckIO(err) <> 0 then begin
            Abort;
            exit(OpenPict)
        end;
        if not Reverting then begin
                iptr := NewPtr(SizeOf(PicInfo));
                if iptr = nil then begin
                        PutMemoryAlert;
                        err := fsclose(PictF);
                        exit(OpenPict)
                    end;
                Info := pointer(iptr);
                CloneInfo(SaveInfo^, Info^);
            end;
        with Info^ do begin
                err := GetEof(PictF, PictSize);
                if CheckIO(err) <> 0 then begin
                    Abort;
                    exit(OpenPict)
                end;
                PictSize := PictSize - 512;
                if PictSize <= 0 then begin
                    Abort;
                    exit(OpenPict)
                end;
                WhatToOpen := OpenPICT2;
                if not OpenHeader(PictF, fname, vnum, TiffInfo) then begin
                    Abort;
                    exit(OpenPict)
                end;
                thePict := PicHandle(NewHandle(SizeOf(Picture)));
                if thePict = nil then begin
                    Abort;
                    exit(OpenPict);
                end;
                err := SetFPos(PictF, fsFromStart, 512);
                if CheckIO(err) <> 0 then begin
                    Abort;
                    exit(OpenPict)
                end;
                howBig := SizeOf(Picture);
                err := FSRead(PictF, howBig, Pointer(thePict^));
                if CheckIO(err) <> 0 then begin
                    Abort;
                    exit(OpenPict)
                end;
                with thePict^^.PicFrame do begin
                        nlines := bottom - top;
                        PixelsPerLine := right - left;
                    end;
         {....}
                err := GetEof(PictF, howBig);
                howBig := howBig - (512 + SizeOf(Picture));
                InitPictBuffer(HowBig * 2);
                if GetPtrSize(PictBuffer) >= howBig then begin
                        err := FSRead(PictF, howBig, PictBuffer);
                        if CheckIO(err) <> NoErr then begin
                                DisposeHandle(handle(thePict));
                                DisposePtr(PictBuffer);
                                err := fsclose(PictF);
                                exit(OpenPict)
                            end;
                        fitsInPictBuffer := true;
                    end
                else
                    fitsInPictBuffer := false;
                if (LutMode = ColorLut) or (LutMode = CustomGrayscale) or (fileVersion = 0) then
                    GetLUTFromPict(thePict);
                if not Reverting then begin
                        p := GetImageMemory(SaveInfo);
                        if p = nil then begin
                                DisposeHandle(handle(thePict));
                                DisposePtr(PictBuffer);
                                err := fsclose(PictF);
                                exit(OpenPict)
                            end;
                        PicBaseAddr := p;
                        MakeNewWindow(fname);
                        if ScreenDepth <> 8 then begin
                            SelectAll(false);
                            DoOperation(EraseOp);
                            changes:= false;
                            KillRoi;
                        end;
                    end;
                if (PixMapSize > UndoBufSize) and (not Reverting) then begin
                        PutWarning;
                        ShowWatch;
                    end;
                if isGrayScaleLUT then
                    ResetGrayMap;
                SaveGDevice := GetGDevice;
                SetGDevice(osGDevice);
                GetPort(tPort);
                SetPort(GrafPtr(osPort));
                pmForeColor(BlackIndex);
                pmBackColor(WhiteIndex);
                RGBForeColor(BlackRGB);
                RGBBackColor(WhiteRGB);
                EraseRect(PicRect);
                SaveProcsPtr := pointer(osPort^.grafProcs);
                SetStdCProcs(tempProcs);
                tempProcs.getPicProc := GetPICTDataProc;
                osPort^.grafProcs := @TempProcs;
                err := SetFPos(PictF, fsFromStart, 512 + SizeOf(Picture));
                FillPictBuffer;
                if not PictReadErr then
                    DrawPicture(thePict, PicRect);
                osPort^.grafProcs := pointer(SaveProcsPtr);
                DisposeHandle(handle(thePict));
                DisposePtr(PictBuffer);
                pmForeColor(ForegroundIndex);
                pmBackColor(BackgroundIndex);
                SetPort(tPort);
                SetGDevice(SaveGDevice);
                vref := vnum;
                PictureType := PictFile;
                revertable := true;
            end; {with}
        err := fsclose(PictF);
        SetupUndo;
        if not PictReadErr then
            OpenPict := true;
    end;


    procedure GetCLUT (thePict: PicHandle);
        type
            myPicData = record
                    p: Picture;
                    ID: integer
                end;
            myPicPtr = ^myPicData;
            myPicHdl = ^myPicPtr;
        var
            tempProcs: CQDProcs;
            SaveProcsPtr: QDProcsPtr;
            err: osErr;
    begin
        with info^ do begin
                SetPort(GrafPtr(osPort));
                SaveProcsPtr := pointer(wptr^.grafProcs);
                SetStdCProcs(tempProcs);
                tempProcs.bitsProc := BitInfoProc;
                BitInfoCount := 0;
                osPort^.grafProcs := @tempProcs;
                DrawPicture(thePict, thePict^^.picFrame);
                osPort^.grafProcs := pointer(SaveProcsPtr);
                LoadLUT(cTable);
            end;
    end;


    function OpenPICS (name: str255; fRefNum: integer): boolean;
        var
            RefNum, picID, hOffset, vOffset, nPICS, i: integer;
            err: OSErr;
            PicH: PicHandle;
            h: handle;
            MemError, Aborted: boolean;
            FrameRect: rect;
            SaveGDevice: GDHandle;
    begin
        if BitInfoProc=nil
            then BitInfoProc:=NewRoutineDescriptor(@BitInfo, uppQDBitsProcInfo, GetCurrentISA);
        OpenPics := false;
        if MaxBlock < MinFree then begin
                PutError('Insufficient memory to open PICS file.');
                exit(OpenPICS);
            end;
        ShowWatch;
        err := SetVol(nil, fRefNum);
        RefNum := OpenResFile(name);
        if RefNum = -1 then begin
                PutError('Unable to open PICS file.');
                exit(OpenPICS);
            end;
        nPICS := Count1Resources('PICT');
        if nPICS < 1 then begin
                PutError('No PICTs found.');
                CloseResFile(RefNum);
                exit(OpenPICS);
            end;
        PicH := GetPicture(128);
        if PicH = nil then begin
            CloseResFile(RefNum);
            exit(OpenPICS);
        end;
        FrameRect := PicH^^.PicFrame;
        with FrameRect do begin
                hOffset := left;
                vOffset := top;
                right := right - hOffset;
                bottom := bottom - vOffset;
                left := 0;
                top := 0;
            end;
        with FrameRect do
            if not NewPicWindow(name, right - left, bottom - top) then begin
                CloseResFile(RefNum);
                exit(OpenPICS);
            end;
        with info^ do begin
                revertable := false;
                StackInfo := StackInfoPtr(NewPtr(SizeOf(StackInfoRec)));
                if StackInfo = nil then begin
                    CloseResFile(RefNum);
                    exit(OpenPICS);
                end;
                with StackInfo^ do begin
                        SliceSpacing := 0.0;
                        FrameInterval := 0.0;
                        StackType := VolumeStack;
                        nSlices := 1;
                        CurrentSlice := 1;
                        PicBaseH[1] := PicBaseHandle;
                    end;
            end;
        if not UseExistingLUT then
            GetCLUT(picH);
        with info^, Info^.StackInfo^ do begin
                SaveGDevice := GetGDevice;
                SetGDevice(osGDevice);
                SetPort(GrafPtr(osPort));
                pmBackColor(WhiteIndex);
                EraseRect(PicRect);
                DrawPicture(picH, PicRect);
                ReleaseResource(handle(PicH));
                SetGDevice(SaveGDevice);
                UpdatePicWindow;
                picID := 129;
                MemError := false;
                for i := 2 to nPICS do begin
                        PicH := GetPicture(picID);
                        if (PicH = nil) or (ResError <> NoErr) then
                            Leave;
                        h := GetBigHandle(PixMapSize);
                        if h = nil then begin
                                if PicH <> nil then
                                    ReleaseResource(handle(picH));
                                MemError := true;
                                Leave;
                            end;
                        nSlices := nSlices + 1;
                        CurrentSlice := CurrentSlice + 1;
                        PicBaseH[CurrentSlice] := h;
                        SelectSlice(CurrentSlice);
                        FrameRect := PicH^^.PicFrame;
                        with FrameRect do begin
                                right := right - hOffset;
                                bottom := bottom - vOffset;
                                left := left - hOffset;
                                top := top - vOffset;
                            end;
                        SetGDevice(osGDevice);
                        EraseRect(PicRect);
                        if not EqualRect(FrameRect, PicRect) then
                            BlockMove(PicBaseH[CurrentSlice - 1]^, PicBaseH[CurrentSlice]^, PixMapSize);
                        DrawPicture(picH, FrameRect);
                        ReleaseResource(handle(PicH));
                        SetGDevice(SaveGDevice);
                        UpdatePicWindow;
                        UpdateTitleBar;
                        Aborted := CommandPeriod;
                        if Aborted then begin
                                beep;
                                wait(60);
                                Leave;
                            end;
                        picID := picID + 1;
                    end;
                CloseResFile(RefNum);
                if MemError then
                    PutError('Not enough memory to open all images in PICS file.');
                CurrentSlice := 1;
                SelectSlice(CurrentSlice);
                PictureType := PicsFile;
                Revertable := false;
                UpdateTitleBar;
                UpdateWindowsMenuItem;
                if not MemError and not Aborted then
                    OpenPICS := true;
            end; {with}
    end;


{$D-}

    procedure OpenAll (RefNum: integer);
      {Opens all appropriate files in a folder.    Original version contributed by Ira Rampil.}
        var
            OpenedOK: boolean;
            index,vRefNum: integer;
            name: Str255;
            ftype: OSType;
            err: OSErr;
            PB: CInfoPBRec;
            dirID,ProcID:LongInt;
    begin
        vRefNum:=0;
        err:=GetWDInfo(RefNum,vRefNum,dirID,ProcID);
        if err<>noErr then
            exit(OpenAll);
        index := 0;
        while true do begin
                index := index + 1;
                with PB do begin
                        ioCompletion := nil;
                        ioNamePtr := @name;
                        ioVRefNum := RefNum;
                        ioDirID:=DirID;
                        ioFDirIndex := index;
                        err := PBGetCatInfoSync(@PB); {ppc-bug}
                        if err = fnfErr then
                            exit(OpenAll);
                        ftype := ioFlFndrInfo.fdType;
                    end;
                if ftype = 'IPIC' then begin
                        WhatToOpen := OpenImage;
                        if not OpenFile(name, RefNum) then
                            exit(OpenAll);
                    end
                else if ftype = 'PICT' then begin
                        if not OpenPICT(name, RefNum, false) then
                            exit(OpenAll)
                    end
                else if ftype = 'TIFF' then begin
                        WhatToOpen := OpenTiff;
                        if not OpenFile(name, RefNum) then
                            exit(OpenAll);
                    end
                else if ftype = 'PNTG' then
                    if not OpenMacPaint(name, RefNum) then
                        exit(OpenAll);
                if CommandPeriod or (nPics>=MaxPics) then begin
                        beep;
                        exit(OpenAll);
                    end;
            end; {while}
    end;


    function OpenDialogHook (item: integer; theDialog: DialogPtr): integer;
        const
            OpenAllID = 11;
            KeepLutID = 12;
        var
            i: integer;
    begin
        if (item = -1) and UseExistingLUT then
            SetDlogItem(theDialog, KeepLutID, 1);
        if item = OpenAllID then begin
                OpenAllFiles := not OpenAllFiles;
                SetDlogItem(theDialog, OpenAllID, ord(OpenAllFiles));
            end;
        if item = KeepLutID then begin
                UseExistingLUT := not UseExistingLUT;
                SetDlogItem(theDialog, KeepLutID, ord(UseExistingLut));
            end;
        OpenDialogHook := item;
    end;


    function isTiffFile (fname: str255; RefNum: integer): boolean;
  {Returns true if the first 16-bit word of the file contains 'MM' or 'II' and the second contains 42.}
        var
            f: integer;
            ByteCount: LongInt;
            hdr: array[1..512] of integer;
            err: OSErr;
    begin
        err := fsopen(fname, RefNum, f);
        err := SetFPos(f, fsFromStart, 0);
        ByteCount := 4;
        err := fsread(f, ByteCount, @hdr);
        isTiffFile := ((hdr[1] = $4949) and (hdr[2] = $2A00) or (hdr[1] = $4D4D) and (hdr[2] = $002A));
        err := fsclose(f);
    end;


    function DoOpen (FileName: str255; RefNum: integer): boolean;
        const
            MyDialogID = 70;
        var
            where: Point;
            reply: SFReply;
            b: boolean;
            TypeList: array[0..11] of OSType;
            FileType: OSType;
            OKToContinue: boolean;
            FinderInfo: FInfo;
            err: OSErr;
            mySpec:FSSpec;
    begin
        if OpenDHookProc=nil
            then OpenDHookProc:=NewRoutineDescriptor(@OpenDialogHook, uppDlgHookProcInfo, GetCurrentISA);
        KillOperation;
        DisableDensitySlice;
        OpenAllFiles := false;
        UseExistingLUT := false;
        OKToContinue := false;
        if FileName = '' then begin
                where.v := 50;
                where.h := 50;
                typeList[0] := 'IPIC';
                typeList[1] := 'PICT';
                typeList[2] := 'TIFF';
                typeList[3] := 'ICOL';   {Color Tables}
                typeList[4] := 'PX05'; {PixelPaint LUT}
                typeList[5] := 'CLUT';  {Klutz LUT}
                typeList[6] := 'drwC';  {Canvas LUT}
                typeList[7] := 'PNTG';  {MacPaint}
                typeList[8] := 'PICS';
                typeList[9] := 'Iout';    {Outlines}
                typeList[10] := 'TEXT';
                typeList[11] := 'MooV';
                SFPGetFile(Where, '', nil, 12, @TypeList, OpenDHookProc, reply, MyDialogID, nil);
                if reply.good then
                    with reply do begin
                            FileName := fname;
                            FileType := ftype;
                            RefNum := vRefNum;
                            DefaultRefNum := RefNum;
                            DefaultFileName := fname;
                            OKToContinue := true;
                        end;
                if reply.good and OpenAllFiles then begin
                        OpenAll(RefNum);
                        exit(DoOpen);
                    end;
            end
        else begin
                err := GetFInfo(FileName, RefNum, FinderInfo);
                FileType := FinderInfo.fdType;
                OKToContinue := true;
            end;
        DoOpen := OKToContinue;
        if OKToContinue then begin
                if FileType = 'IPIC' then begin
                        WhatToOpen := OpenImage;
                        b := OpenFile(FileName, RefNum)
                    end
                else if FileType = 'PICT' then begin
                        b := OpenPICT(FileName, RefNum, false)
                    end
                else if FileType = 'TIFF' then begin
                        WhatToOpen := OpenTIFF;
                        b := OpenFile(FileName, RefNum)
                    end
                else if FileType = 'ICOL' then
                    OpenColorTable(FileName, RefNum)
                else if FileType = 'PX05' then
                    ImportPalette('PX05', FileName, RefNum)
                else if FileType = 'CLUT' then
                    ImportPalette('CLUT', FileName, RefNum)
                else if FileType = 'drwC' then
                    ImportPalette('PX05', FileName, RefNum)
                else if FileType = 'PNTG' then
                    b := OpenMacPaint(FileName, RefNum)
                else if FileType = 'PICS' then
                    b := OpenPICS(FileName, RefNum)
                else if FileType = 'Iout' then
                    OpenOutline(FileName, RefNum)
                else if FileType = 'TEXT' then begin
                        if isTiffFile(FileName, RefNum) and not OptionKeyWasDown then begin
                                WhatToOpen := OpenTIFF;
                                b := OpenFile(FileName, RefNum)
                            end
                        else
                            b := OpenTextFile(FileName, RefNum)
                    end
                else if FileType = 'MooV' then
                    b := OpenQuickTime(FileName, RefNum, UseExistingLUT)
                else begin
                        WhatToOpen := OpenUnknown;
                        b := OpenFile(FileName, RefNum)
                    end;
                info^.ScaleToFitWindow := false;
                if macro then
                    GenerateValues;
            end;
    end;


    procedure ImportAllFiles (RefNum: integer);
        var
            OpenedOK: boolean;
            index, vRefNum: integer;
            name: Str255;
            ftype: OSType;
            err: OSErr;
            PB: CInfoPBRec;
            dirID,ProcID:LongInt;
    begin
        vRefNum:=0;
        err:=GetWDInfo(RefNum, vRefNum, dirID, ProcID);
        if err<>noErr then
            exit(ImportAllFiles);
        index := 0;
        while true do begin
                index := index + 1;
                with PB do begin
                        ioCompletion := nil;
                        ioNamePtr := @name;
                        ioVRefNum := RefNum;
                        ioDirID:=dirID;
                        ioFDirIndex := index;
                        err := PBGetCatInfoSync(@PB); {ppc-bug}
                        if err = fnfErr then
                            exit(ImportAllFiles);
                        ftype := ioFlFndrInfo.fdType;
                    end;
                if (WhatToOpen = OpenCustom) and (ImportCustomDepth <> EightBits) then begin
                        if not Import16BitFile(name, RefNum) then
                            exit(ImportAllFiles);
                    end
                else begin
                        if not OpenFile(name, RefNum) then
                            exit(ImportAllFiles);
                    end;
                if CommandPeriod or (nPics>=MaxPics) then begin
                        beep;
                        exit(ImportAllFiles);
                    end;
            end; {while}
    end;


    procedure EditImportParameters;
        const
            WidthID = 2;
            HeightID = 3;
            OffsetID = 4;
            SlicesID = 5;
            FixedID = 6;
            MinID = 7;
            MaxID = 8;
        var
            mylog: DialogPtr;
            item, fwidth: integer;
    begin
        mylog := GetNewDialog(110, nil, pointer(-1));
        SetDNum(MyLog, WidthID, ImportCustomWidth);
        SelectdialogItemText(MyLog, WidthID, 0, 32767);
        SetDNum(MyLog, HeightID, ImportCustomHeight);
        SetDNum(MyLog, SlicesID, ImportCustomSlices);
        SetDNum(MyLog, OffsetID, ImportCustomOffset);
        SetDlogItem(MyLog, FixedID, ord(not ImportAutoScale));
        if WhatToImport = ImportText then
            fwidth := 2
        else
            fwidth := 0;
        SetDReal(MyLog, MinID, ImportMin, fwidth);
        SetDReal(MyLog, MaxID, ImportMax, fwidth);
        OutlineButton(MyLog, ok, 16);
        repeat
            ModalDialog(nil, item);
            if item = WidthID then begin
                    ImportCustomWidth := GetDNum(MyLog, WidthID);
                    if (ImportCustomWidth < 0) or (ImportCustomWidth > MaxPicSize) then begin
                            ImportCustomWidth := 512;
                            SetDNum(MyLog, WidthID, ImportCustomWidth);
                        end;
                end;
            if item = HeightID then begin
                    ImportCustomHeight := GetDNum(MyLog, HeightID);
                    if ImportCustomHeight < 0 then begin
                            ImportCustomHeight := 512;
                            SetDNum(MyLog, HeightID, ImportCustomHeight);
                        end;
                end;
            if item = SlicesID then begin
                    ImportCustomSlices := GetDNum(MyLog, SlicesID);
                    if ImportCustomSlices < 0 then begin
                            ImportCustomSlices := 1;
                            SetDNum(MyLog, SlicesID, ImportCustomSlices);
                        end;
                    if ImportCustomSlices > MaxSlices then begin
                            ImportCustomSlices := MaxSlices;
                            SetDNum(MyLog, SlicesID, ImportCustomSlices);
                        end;
                end;
            if item = OffsetID then begin
                    ImportCustomOffset := GetDNum(MyLog, OffsetID);
                    if ImportCustomOffset < 0 then begin
                            ImportCustomOffset := 0;
                            SetDNum(MyLog, OffsetID, ImportCustomOffset);
                        end;
                end;
            if item = FixedID then begin
                    ImportAutoScale := not ImportAutoScale;
                    SetDlogItem(mylog, FixedID, ord(not ImportAutoScale));
                end;
            if item = MinID then begin
                    ImportMin := GetDReal(MyLog, MinID);
                    ImportAutoScale := false;
                    SetDlogItem(MyLog, FixedID, 1);
                end;
            if item = MaxID then begin
                    ImportMax := GetDReal(MyLog, MaxID);
                    ImportAutoScale := false;
                    SetDlogItem(MyLog, FixedID, 1);
                end;
        until item = ok;
        DisposeDialog(mylog);
    end;


    function ImportDialogHook (item: integer; myLog: DialogPtr): integer;
        const
            TiffID = 11;
            DicomID = 12;
            TextID = 13;
            LutID = 14;
            CustomID = 15;
            WidthAndHeightID = 16;
            OffsetID = 17;
            EightBitsID = 18;
            SixteenBitsUnsignedID = 19;
            SixteenBitsSignedID = 20;
            SwapBytesID = 21;
            ImportAllID = 22;
            EditID = 23;
            CalibrateID = 24;
            InvertID = 25;

        var
            i: integer;

        procedure SetRadioButtons1;
            var
                i: integer;
        begin
            SetDlogItem(mylog, TiffID, 0);
            SetDlogItem(mylog, DicomID, 0);
            SetDlogItem(mylog, LutID, 0);
            SetDlogItem(mylog, TextID, 0);
            SetDlogItem(mylog, CustomID, 0);
            case WhatToImport of
                ImportTiff:
                    SetDlogItem(mylog, TiffID, 1);
                ImportDicom:
                    SetDlogItem(mylog, DicomID, 1);
                ImportLUT:
                    SetDlogItem(mylog, LutID, 1);
                ImportText:
                    SetDlogItem(mylog, TextID, 1);
                ImportCustom:
                    SetDlogItem(mylog, CustomID, 1);
            end;
        end;

        procedure SetRadioButtons2;
            var
                i: integer;
        begin
            SetDlogItem(mylog, EightBitsID, 0);
            SetDlogItem(mylog, SixteenBitsUnsignedID, 0);
            SetDlogItem(mylog, SixteenBitsSignedID, 0);
            case ImportCustomDepth of
                EightBits:
                    SetDlogItem(mylog, EightBitsID, 1);
                SixteenBitsUnsigned:
                    SetDlogItem(mylog, SixteenBitsUnsignedID, 1);
                SixteenBitsSigned:
                    SetDlogItem(mylog, SixteenBitsSignedID, 1);
            end;
        end;

        procedure ShowParameters;
            var
                str1, str2, str3: str255;
        begin
            NumToString(ImportCustomWidth, str1);
            NumToString(ImportCustomHeight, str2);
            NumToString(ImportCustomOffset, str3);
            ParamText(str1, str2, str3, '');
        end;

    begin
        if item = -1 then begin {Initialize}
                SetRadioButtons1;
                SetRadioButtons2;
                ShowParameters;
                SetDlogItem(mylog, SwapBytesID, ord(ImportSwapBytes));
                SetDlogItem(mylog, ImportAllID, ord(ImportAll));
                SetDlogItem(mylog, InvertID, ord(ImportInvert));
                SetDlogItem(mylog, CalibrateID, ord(ImportCalibrate));
            end;
        if (item >= TiffID) and (item <= CustomID) then begin
                case item of
                    TiffID:
                        WhatToImport := ImportTiff;
                    DicomID:
                        WhatToImport := ImportDicom;
                    LutID:
                        WhatToImport := ImportLUT;
                    TextID:
                        WhatToImport := ImportText;
                    CustomID:
                        WhatToImport := ImportCustom;
                end;
                SetRadioButtons1;
            end;
        if item = EditID then begin
                EditImportParameters;
                WhatToImport := ImportCustom;
                SetRadioButtons1;
                ShowParameters;
                SetDlogItem(mylog, CalibrateID, ord(ImportCalibrate));
            end;
        if (item >= EightBitsID) and (item <= SixteenBitsSignedID) then begin
                case item of
                    EightBitsID:
                        ImportCustomDepth := EightBits;
                    SixteenBitsUnsignedID:
                        ImportCustomDepth := SixteenBitsUnsigned;
                    SixteenBitsSignedID:
                        ImportCustomDepth := SixteenBitsSigned;
                end;
                SetRadioButtons2;
                WhatToImport := ImportCustom;
                SetRadioButtons1;
            end;
        if item = SwapBytesID then begin
                ImportSwapBytes := not ImportSwapBytes;
                SetDlogItem(mylog, SwapBytesID, ord(ImportSwapBytes));
                WhatToImport := ImportCustom;
                SetRadioButtons1;
            end;
        if item = ImportAllID then begin
                ImportAll := not ImportAll;
                SetDlogItem(mylog, ImportAllID, ord(ImportAll));
            end;
        if item = InvertID then begin
                ImportInvert := not ImportInvert;
                SetDlogItem(mylog, InvertID, ord(ImportInvert));
            end;
        if item = CalibrateID then begin
                ImportCalibrate := not ImportCalibrate;
                SetDlogItem(mylog, CalibrateID, ord(ImportCalibrate));
                WhatToImport := ImportCustom;
                SetRadioButtons1;
            end;
        ImportDialogHook := item;
    end;


    function ImportFile (FileName: str255; RefNum: integer): boolean;
        const
            ImportDialogID = 90;
        var
            where: Point;
            typeList: SFTypeList;
            reply: SFReply;
            b, ImportingTIFF, HasColorMap: boolean;
    begin
        if ImportDHookProc=nil
            then ImportDHookProc:=NewRoutineDescriptor(@ImportDialogHook, uppDlgHookProcInfo, GetCurrentISA);
        ImportFile := true;
        DisableDensitySlice;
        if not macro then begin
            ImportAll := false;
            if WhatToImport=ImportMCID then
                WhatToImport:=ImportTIFF;
        end;
        if FileName = '' then begin
                where.v := 50;
                where.h := 50;
                SFPGetFile(Where, '', nil, -1, @typeList, ImportDHookProc, reply, ImportDialogID, nil);
                if not reply.good then begin
                        ImportFile := false;
                        exit(ImportFile);
                    end;
                with reply do begin
                        FileName := fname;
                        RefNum := vRefNum;
                        DefaultRefNum := RefNum;
                        DefaultFileName := fname;
                    end;
            end;
        if isTiffFile(FileName, RefNum) and not macro and not OptionKeyWasDown then
            WhatToImport := ImportTiff;
        ImportingTIFF := WhatToImport = ImportTiff;
        if ImportingTIFF then
            if not GetTIFFParameters(FileName, RefNum, HasColorMap) then
                exit(ImportFile);
        case WhatToImport of
            ImportMCID:
                WhatToOpen := OpenImported;
            ImportCustom:  begin
                    if (ImportCustomDepth <> EightBits) and (ImportCustomWidth > MaxLine) then begin
                            PutError(concat('Maximum width of imported 16-bit images is ', long2str(MaxLine), '.'));
                            exit(ImportFile);
                        end;
                    WhatToOpen := OpenCustom;
                end;
            ImportDicom:
               begin
                    ImportDicomImages(FileName, RefNum, ImportAll, ImportFile);
                    exit(ImportFile);
               end
            ImportLUT:  begin
                    DoImportLut(FileName, RefNum);
                    exit(ImportFile);
                end;
            ImportText:  begin
                    ImportFile := ImportTextFile(FileName, RefNum);
                    exit(ImportFile);
                end;
            otherwise;
        end;
        if ImportAll then
            ImportAllFiles(RefNum)
        else if (WhatToOpen = OpenCustom) and (ImportCustomDepth <> EightBits) then
            b := Import16BitFile(FileName, RefNum)
        else
            b := OpenFile(FileName, RefNum);
        if macro then
            GenerateValues;
        if ImportingTIFF then
            WhatToImport := ImportTiff; {GetTIFFParameters may have changed it to ImportCustom.}
    end;


    procedure RevertToSaved;
        var
            fname: str255;
            err, f: integer;
            ok: boolean;
            size: LongInt;
    begin
        if OpPending then
            KillRoi;
        DisableDensitySlice;
        with Info^ do begin
                fname := title;
                SetPort(wptr);
                if PictureType = PICTFile then begin
                        ok := OpenPICT(fname, vref, true);
                        UpdatePicWindow;
                    end
                else begin
                        ShowWatch;
                        err := fsopen(fname, vref, f);
                        ok := true;
                        if HeaderOffset <> -1 then
                            ok := OpenImageHeader(f, fname, vref);
                        if ok then begin
                                err := SetFPos(f, fsFromStart, ImageDataOffset);
                                size := ImageSize;
                                CheckFileSize(f, size, ImageDataOffset);
                                if size > 0 then
                                    err := fsread(f, size, PicBaseAddr);
                                if odd(PixelsPerLine) then
                                    UnpackLines;
                                if Info^.InvertedImage then
                                    InvertPic;
                                UpdatePicWindow;
                            end;
                        err := fsclose(f);
                        RoiShowing := false;
                    end;
                OpPending := false;
                Changes := false;
                UpdateTitleBar;
            end; {with}
    end;


    procedure FindWhatToPrint;
        var
            kind: integer;
            WhichWindow: WindowPtr;
    begin
        WhatToPrint := NothingToPrint;
        WhichWindow := FrontWindow;
        if WhichWindow = nil then
            exit(FindWhatToPrint);
        kind := WindowPeek(WhichWindow)^.WindowKind;
        if (kind = PicKind) and info^.RoiShowing and measuring then
            kind := InfoKind;
        case kind of
            PicKind:
                if info^.RoiShowing then
                    WhatToPrint := PrintSelection
                else
                    WhatToPRint := PrintImage;
            HistoKind:
                WhatToPrint := PrintHistogram;
            ProfilePlotKind, CalibrationPlotKind:
                WhatToPrint := PrintPlot;
            InfoKind, ResultsKind:
                if mCount > 0 then
                    WhatToPrint := PrintMeasurements;
            TextKind:
                WhatToPrint := PrintText;
            otherwise
                ;
        end;
        if (WhatToPrint = NothingToPRint) and (info <> NoInfo) then
            WhatToPrint := PrintImage;
    end;


    procedure CheckRoiBounds;
    begin
        with info^, info^.RoiRect do
            if (left < 0) or (top < 0) or (right > PicRect.right) or (bottom > PicRect.bottom) then
                KillRoi;
    end;


    procedure UpdateFileMenu;
        var
            ShowItems, isSelection, notStack: boolean;
            i: integer;
            str, str2: str255;
    begin
        with info^ do begin
                ShowItems := Info <> NoInfo;
                CheckRoiBounds;
                isSelection := RoiShowing and (RoiType = RectRoi);
                notStack := StackInfo = nil;
                if OptionKeyWasDown and (CurrentKind <> TextKind) then begin
                        SetMenuItemText(FileMenuH, CloseItem, 'Close All…');
                        SetMenuItemText(FileMenuH, SaveItem, 'Save All');
                        SetMenuItem(FileMenuH, CloseItem, ShowItems);
                    end
                else begin
                        SetMenuItemText(FileMenuH, CloseItem, 'Close…');
                        if isSelection and notStack and (CurrentKind <> TextKind) and (PictureType <> TiffFile) and (PictureType <> PictFile) and (CurrentKind = PicKind) then
                            SetMenuItemText(FileMenuH, SaveItem, 'Save Selection')
                        else
                            SetMenuItemText(FileMenuH, SaveItem, 'Save');
                        SetMenuItem(FileMenuH, CloseItem, ShowItems or (CurrentKind = TextKind) or (CurrentKind = ResultsKind) or (CurrentKind = ProfilePlotKind) or (CurrentKind = CalibrationPlotKind) or (CurrentKind = HistoKind));
                    end;
                case CurrentKind of
                    ProfilePlotKind, CalibrationPlotKind:
                        ExportAsWhat := asPlotValues;
                    HistoKind:
                        ExportAsWhat := asHistogramValues;
                    ResultsKind:
                        ExportAsWhat := asMeasurements;
                    PicKind:  begin
                            if (SaveAsWhat <> asPICT) then
                                SaveAsWhat := asTiff;
                            if (ExportAsWhat > asText) then
                                ExportAsWhat := asRaw;
                        end;
                    otherwise
                end;
                if isSelection and notStack and (SaveAsWhat <> AsPalette) and (CurrentKind <> ResultsKind) and (CurrentKind <> TextKind) then
                    SetMenuItemText(FileMenuH, SaveAsItem, 'Save Selection As…')
                else
                    SetMenuItemText(FileMenuH, SaveAsItem, 'Save As…');
                if isSelection and notStack and (ExportAsWhat <= AsText) then
                    SetMenuItemText(FileMenuH, ExportItem, 'Export Selection As…')
                else
                    SetMenuItemText(FileMenuH, ExportItem, 'Export…');
                for i := SaveItem to SaveAsItem do
                    SetMenuItem(FileMenuH, i, ShowItems or (CurrentKind = TextKind));
                SetMenuItem(FileMenuH, ExportItem, (ShowItems or (CurrentKind = ResultsKind)) and (CurrentKind <> TextKind));
                if isSelection then
                    str := 'Duplicate Selection'
                else
                    str := 'Duplicate';
                SetMenuItemText(FileMenuH, DuplicateItem, str);
                for i := DuplicateItem to GetInfoItem do
                    SetMenuItem(FileMenuH, i, ShowItems and (CurrentKind <> TextKind));
                if DataType <> EightBits then
                    str := 'Rescale'
                else
                    str := 'Revert to Saved';
                SetMenuItemText(FileMenuH, RevertItem, str);
                SetMenuItem(FileMenuH, RevertItem, (Revertable or (DataType <> EightBits)) and (CurrentKind <> TextKind));
                SetMenuItem(FileMenuH, PlugInExportItem, ShowItems);
                FindWhatToPrint;
                case WhatToPrint of
                    NothingToPrint:
                        str := '';
                    PrintImage:
                        str := 'Image';
                    PrintSelection:
                        str := 'Selection';
                    PrintPlot:
                        str := 'Plot';
                    PrintHistogram:
                        str := 'Histogram';
                    PrintMeasurements:
                        str := 'Results';
                    PrintText:
                        str := 'Text';
                end;
                SetMenuItemText(FileMenuH, PrintItem, concat('Print ', str, '…'));
                SetMenuItem(FileMenuH, PrintItem, WhatToPrint <> NothingToPrint);
            end; {with info^}
    end;


    procedure SaveAll;
        var
            SaveInfo: InfoPtr;
            i: integer;
    begin
        SaveInfo := Info;
        SaveAsWhat := AsTiff;
        SaveAllState := SaveAllStage1;
        for i := 1 to nPics do begin
                Info := pointer(WindowPeek(PicWindow[i])^.RefCon);
                SaveAs('', 0);
                if CommandPeriod or (SaveAllState = NoSaveAll) then
                    leave;
            end;
        Info := SaveInfo;
        SaveAllState := NoSaveAll;
    end;


    function SuggestedExportName: str255;
        var
            name: str255;
    begin
        name := info^.title;
        case ExportAsWhat of
            asRaw, asMCID, asText:  begin
                    if name = 'Camera' then
                        name := 'Untitled';
                    if ExportAsWhat = AsText then
                        SuggestedExportName := concat(name, ' (Text)')
                    else
                        SuggestedExportName := name;
                end;
            AsLUT:
                SuggestedExportName := 'Palette';
            asMeasurements:
                SuggestedExportName := concat(name, ' (Measurements)');
            AsPlotValues:
                SuggestedExportName := concat(name, ' (Plot Values)');
            asHistogramValues:
                SuggestedExportName := concat(name, ' (Histogram)');
            asCoordinates:
                SuggestedExportName := concat(name, ' (Coordinates)');
        end;
    end;


    function ExportHook (item: integer; theDialog: DialogPtr): integer;
        const
            EditTextID = 7;
            RawID = 9;
            xyCoordinatesID = 16;
        var
            i: integer;
            fname: str255;
            NameEdited: boolean;
    begin
        if item = -1 then {Initialize}
            SetDlogItem(theDialog, RawID + ord(ExportAsWhat), 1);
        fname := GetDString(theDialog, EditTextID);
        NameEdited := fname <> SuggestedExportName;
        if (item >= RawID) and (item <= xyCoordinatesID) then begin
                ExportAsWhat := ExportAsWhatType(item - RawID);
                if not NameEdited then begin
                        SetDString(theDialog, EditTextID, SuggestedExportName);
                        SelectdialogItemText(theDialog, EditTextID, 0, 32767);
                    end;
                for i := RawID to xyCoordinatesID do
                    SetDlogItem(theDialog, i, 0);
                SetDlogItem(theDialog, item, 1);
            end;
        ExportHook := item;
    end;


    procedure Export (name: str255; RefNum: integer);
        const
            CustomDialogID = 100;
        var
            where: Point;
            reply: SFReply;
            isSelection: boolean;
            kind: integer;
            SaveAsState: SaveAsWhatType;
    begin
        if ExportDHookProc=nil
            then ExportDHookProc:=NewRoutineDescriptor(@ExportHook, uppDlgHookProcInfo, GetCurrentISA);
        with info^ do begin
                if (name = '') or ((RefNum = 0) and (pos(':', name) = 0)) then begin
                        where.v := 50;
                        where.h := 50;
                        if name = '' then
                            name := SuggestedExportName;
                        SFPPutFile(Where, 'Save as?', name, ExportDHookProc, reply, CustomDialogID, nil);
                        if not reply.good then begin
                                AbortMacro;
                                exit(Export);
                            end;
                        with reply do begin
                                name := fname;
                                RefNum := vRefNum;
                                DefaultRefNum := RefNum;
                            end;
                    end;
                if (Info = NoInfo) and (ExportAsWhat <= asText) then begin
                    PutError('No image data available.');
                    AbortMacro;
                    exit(Export);
                end;
                CheckRoiBounds;
                isSelection := RoiShowing and (RoiType = RectRoi);
                case ExportAsWhat of
                    asRaw, asMCID:  begin
                            if ExportAsWhat = asMCID then
                                InvertPic;
                            SaveAsState := SaveAsWhat;
                            if ExportAsWhat = AsRaw then
                                SaveAsWhat := asRawData
                            else
                                SaveAsWhat := SaveAsMCID;
                            if isSelection then
                                SaveSelection(name, RefNum, false)
                            else
                                SaveAsTIFF(name, RefNum, 0, 0, false);
                            SaveAsWhat := SaveAsState;
                        end;
                    AsText:
                        ExportAsText(name, RefNum);
                    AsLUT:
                        SaveLUT(name, RefNum);
                    asMeasurements:
                        if mCount > 0 then
                            ExportMeasurements(name, RefNum)
                        else
                            PutError('Sorry, but no measurements are available to export.');
                    AsPlotValues:
                        if PlotWindow <> nil then begin
                                kind := WindowPeek(PlotWindow)^.WindowKind;
                                case kind of
                                    ProfilePlotKind:
                                        ConvertPlotToText;
                                    CalibrationPlotKind:
                                        ConvertCalibrationCurveToText;
                                    otherwise
                                        TextBufSize := 0;
                                end;
                                SaveAsText(name, RefNum);
                            end
                        else
                            beep;
                    asHistogramValues:
                        if HistoWindow <> nil then begin
                                ConvertHistoToText;
                                SaveAsText(name, RefNum);
                            end
                        else
                            beep;
                    asCoordinates:
                        ExportCoordinates(name, RefNum);
                    otherwise
                        beep;
                end; {case}
                if (SaveAsWhat = asRawData) and (SaveAllState <> SaveAllStage2) then
                    SaveAsWhat := asTIFF;
            end; {with}
    end;



end.